3 * Copyright (c) 1991-1999, 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
22 #define CHECKCALL this->*PL_check
24 #define CHECKCALL *PL_check
27 /* #define PL_OP_SLAB_ALLOC */
29 #ifdef PL_OP_SLAB_ALLOC
30 #define SLAB_SIZE 8192
31 static char *PL_OpPtr = NULL;
32 static int PL_OpSpace = 0;
33 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
34 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
36 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
40 Slab_Alloc(int m, size_t sz)
42 Newz(m,PL_OpPtr,SLAB_SIZE,char);
43 PL_OpSpace = SLAB_SIZE - sz;
44 return PL_OpPtr += PL_OpSpace;
48 #define NewOp(m, var, c, type) Newz(m, var, c, type)
51 * In the following definition, the ", Nullop" is just to make the compiler
52 * think the expression is of the right type: croak actually does a Siglongjmp.
54 #define CHECKOP(type,o) \
55 ((PL_op_mask && PL_op_mask[type]) \
56 ? ( op_free((OP*)o), \
57 croak("%s trapped by operation mask", PL_op_desc[type]), \
59 : (CHECKCALL[type])((OP*)o))
61 #define PAD_MAX 999999999
63 static bool scalar_mod_type _((OP *o, I32 type));
65 static I32 list_assignment _((OP *o));
66 static void bad_type _((I32 n, char *t, char *name, OP *kid));
67 static OP *modkids _((OP *o, I32 type));
68 static OP *no_fh_allowed _((OP *o));
69 static OP *scalarboolean _((OP *o));
70 static OP *too_few_arguments _((OP *o, char* name));
71 static OP *too_many_arguments _((OP *o, char* name));
72 static void null _((OP* o));
73 static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq,
74 CV* startcv, I32 cx_ix, I32 saweval, U32 flags));
75 static OP *newDEFSVOP _((void));
76 static OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp));
77 static void simplify_sort _((OP *o));
78 static bool is_handle_constructor _((OP *o, I32 argnum));
85 SV* tmpsv = sv_newmortal();
86 gv_efullname3(tmpsv, gv, Nullch);
87 return SvPV(tmpsv,n_a);
93 yyerror(form("Missing comma after first argument to %s function",
94 PL_op_desc[o->op_type]));
99 too_few_arguments(OP *o, char *name)
101 yyerror(form("Not enough arguments for %s", name));
106 too_many_arguments(OP *o, char *name)
108 yyerror(form("Too many arguments for %s", name));
113 bad_type(I32 n, char *t, char *name, OP *kid)
115 yyerror(form("Type of arg %d to %s must be %s (not %s)",
116 (int)n, name, t, PL_op_desc[kid->op_type]));
122 int type = o->op_type;
123 if (type != OP_AELEM && type != OP_HELEM && type != OP_GELEM) {
124 yyerror(form("Can't use subscript on %s", PL_op_desc[type]));
125 if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV) {
127 SV *msg = sv_2mortal(
128 newSVpvf("(Did you mean $ or @ instead of %c?)\n",
129 type == OP_ENTERSUB ? '&' : '%'));
133 sv_catsv(GvSV(PL_errgv), msg);
135 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
140 /* "register" allocation */
143 pad_allocmy(char *name)
151 (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) ||
152 name[1] == '_' && (int)strlen(name) > 2))
154 if (!isPRINT(name[1])) {
155 /* 1999-02-27 mjd@plover.com */
157 p = strchr(name, '\0');
158 /* The next block assumes the buffer is at least 205 chars
159 long. At present, it's always at least 256 chars. */
161 strcpy(name+200, "...");
167 /* Move everything else down one character */
168 for (; p-name > 2; p--)
170 name[2] = toCTRL(name[1]);
173 yyerror(form("Can't use global %s in \"my\"",name));
175 if (ckWARN(WARN_UNSAFE) && AvFILLp(PL_comppad_name) >= 0) {
176 SV **svp = AvARRAY(PL_comppad_name);
177 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_floor; off--) {
179 && sv != &PL_sv_undef
180 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
181 && strEQ(name, SvPVX(sv)))
184 "\"my\" variable %s masks earlier declaration in same %s",
185 name, (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
190 off = pad_alloc(OP_PADSV, SVs_PADMY);
192 sv_upgrade(sv, SVt_PVNV);
194 if (PL_in_my_stash) {
196 yyerror(form("Can't declare class for non-scalar %s in \"my\"",
199 (void)SvUPGRADE(sv, SVt_PVMG);
200 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
203 av_store(PL_comppad_name, off, sv);
204 SvNVX(sv) = (double)PAD_MAX;
205 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
206 if (!PL_min_intro_pending)
207 PL_min_intro_pending = off;
208 PL_max_intro_pending = off;
210 av_store(PL_comppad, off, (SV*)newAV());
211 else if (*name == '%')
212 av_store(PL_comppad, off, (SV*)newHV());
213 SvPADMY_on(PL_curpad[off]);
217 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
220 pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval,
228 register PERL_CONTEXT *cx;
230 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
231 AV *curlist = CvPADLIST(cv);
232 SV **svp = av_fetch(curlist, 0, FALSE);
235 if (!svp || *svp == &PL_sv_undef)
238 svp = AvARRAY(curname);
239 for (off = AvFILLp(curname); off > 0; off--) {
240 if ((sv = svp[off]) &&
241 sv != &PL_sv_undef &&
243 seq > I_32(SvNVX(sv)) &&
244 strEQ(SvPVX(sv), name))
255 return 0; /* don't clone from inactive stack frame */
259 oldpad = (AV*)*av_fetch(curlist, depth, FALSE);
260 oldsv = *av_fetch(oldpad, off, TRUE);
261 if (!newoff) { /* Not a mere clone operation. */
262 SV *namesv = NEWSV(1103,0);
263 newoff = pad_alloc(OP_PADSV, SVs_PADMY);
264 sv_upgrade(namesv, SVt_PVNV);
265 sv_setpv(namesv, name);
266 av_store(PL_comppad_name, newoff, namesv);
267 SvNVX(namesv) = (double)PL_curcop->cop_seq;
268 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
269 SvFAKE_on(namesv); /* A ref, not a real var */
270 if (SvOBJECT(sv)) { /* A typed var */
272 (void)SvUPGRADE(namesv, SVt_PVMG);
273 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(sv));
276 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
277 /* "It's closures all the way down." */
278 CvCLONE_on(PL_compcv);
280 if (CvANON(PL_compcv))
281 oldsv = Nullsv; /* no need to keep ref */
286 bcv && bcv != cv && !CvCLONE(bcv);
287 bcv = CvOUTSIDE(bcv))
292 if (ckWARN(WARN_CLOSURE)
293 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
296 "Variable \"%s\" may be unavailable",
304 else if (!CvUNIQUE(PL_compcv)) {
305 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv))
307 "Variable \"%s\" will not stay shared", name);
310 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
316 if (flags & FINDLEX_NOSEARCH)
319 /* Nothing in current lexical context--try eval's context, if any.
320 * This is necessary to let the perldb get at lexically scoped variables.
321 * XXX This will also probably interact badly with eval tree caching.
324 for (i = cx_ix; i >= 0; i--) {
326 switch (CxTYPE(cx)) {
328 if (i == 0 && saweval) {
329 seq = cxstack[saweval].blk_oldcop->cop_seq;
330 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
334 switch (cx->blk_eval.old_op_type) {
340 /* require must have its own scope */
348 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
349 saweval = i; /* so we know where we were called from */
352 seq = cxstack[saweval].blk_oldcop->cop_seq;
353 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
361 pad_findmy(char *name)
367 SV **svp = AvARRAY(PL_comppad_name);
368 U32 seq = PL_cop_seqmax;
374 * Special case to get lexical (and hence per-thread) @_.
375 * XXX I need to find out how to tell at parse-time whether use
376 * of @_ should refer to a lexical (from a sub) or defgv (global
377 * scope and maybe weird sub-ish things like formats). See
378 * startsub in perly.y. It's possible that @_ could be lexical
379 * (at least from subs) even in non-threaded perl.
381 if (strEQ(name, "@_"))
382 return 0; /* success. (NOT_IN_PAD indicates failure) */
383 #endif /* USE_THREADS */
385 /* The one we're looking for is probably just before comppad_name_fill. */
386 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
387 if ((sv = svp[off]) &&
388 sv != &PL_sv_undef &&
391 seq > I_32(SvNVX(sv)))) &&
392 strEQ(SvPVX(sv), name))
395 return (PADOFFSET)off;
396 pendoff = off; /* this pending def. will override import */
400 outside = CvOUTSIDE(PL_compcv);
402 /* Check if if we're compiling an eval'', and adjust seq to be the
403 * eval's seq number. This depends on eval'' having a non-null
404 * CvOUTSIDE() while it is being compiled. The eval'' itself is
405 * identified by CvEVAL being true and CvGV being null. */
406 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
407 cx = &cxstack[cxstack_ix];
409 seq = cx->blk_oldcop->cop_seq;
412 /* See if it's in a nested scope */
413 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
415 /* If there is a pending local definition, this new alias must die */
417 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
418 return off; /* pad_findlex returns 0 for failure...*/
420 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
424 pad_leavemy(I32 fill)
427 SV **svp = AvARRAY(PL_comppad_name);
429 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
430 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
431 if ((sv = svp[off]) && sv != &PL_sv_undef)
432 warn("%s never introduced", SvPVX(sv));
435 /* "Deintroduce" my variables that are leaving with this scope. */
436 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
437 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
438 SvIVX(sv) = PL_cop_seqmax;
443 pad_alloc(I32 optype, U32 tmptype)
449 if (AvARRAY(PL_comppad) != PL_curpad)
450 croak("panic: pad_alloc");
451 if (PL_pad_reset_pending)
453 if (tmptype & SVs_PADMY) {
455 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
456 } while (SvPADBUSY(sv)); /* need a fresh one */
457 retval = AvFILLp(PL_comppad);
460 SV **names = AvARRAY(PL_comppad_name);
461 SSize_t names_fill = AvFILLp(PL_comppad_name);
464 * "foreach" index vars temporarily become aliases to non-"my"
465 * values. Thus we must skip, not just pad values that are
466 * marked as current pad values, but also those with names.
468 if (++PL_padix <= names_fill &&
469 (sv = names[PL_padix]) && sv != &PL_sv_undef)
471 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
472 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)))
477 SvFLAGS(sv) |= tmptype;
478 PL_curpad = AvARRAY(PL_comppad);
480 DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx alloc %ld for %s\n",
481 (unsigned long) thr, (unsigned long) PL_curpad,
482 (long) retval, PL_op_name[optype]));
484 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx alloc %ld for %s\n",
485 (unsigned long) PL_curpad,
486 (long) retval, PL_op_name[optype]));
487 #endif /* USE_THREADS */
488 return (PADOFFSET)retval;
496 DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx sv %d\n",
497 (unsigned long) thr, (unsigned long) PL_curpad, po));
500 croak("panic: pad_sv po");
501 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx sv %d\n",
502 (unsigned long) PL_curpad, po));
503 #endif /* USE_THREADS */
504 return PL_curpad[po]; /* eventually we'll turn this into a macro */
508 pad_free(PADOFFSET po)
513 if (AvARRAY(PL_comppad) != PL_curpad)
514 croak("panic: pad_free curpad");
516 croak("panic: pad_free po");
518 DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx free %d\n",
519 (unsigned long) thr, (unsigned long) PL_curpad, po));
521 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx free %d\n",
522 (unsigned long) PL_curpad, po));
523 #endif /* USE_THREADS */
524 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef)
525 SvPADTMP_off(PL_curpad[po]);
526 if ((I32)po < PL_padix)
531 pad_swipe(PADOFFSET po)
534 if (AvARRAY(PL_comppad) != PL_curpad)
535 croak("panic: pad_swipe curpad");
537 croak("panic: pad_swipe po");
539 DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx swipe %d\n",
540 (unsigned long) thr, (unsigned long) PL_curpad, po));
542 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx swipe %d\n",
543 (unsigned long) PL_curpad, po));
544 #endif /* USE_THREADS */
545 SvPADTMP_off(PL_curpad[po]);
546 PL_curpad[po] = NEWSV(1107,0);
547 SvPADTMP_on(PL_curpad[po]);
548 if ((I32)po < PL_padix)
552 /* XXX pad_reset() is currently disabled because it results in serious bugs.
553 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
554 * on the stack by OPs that use them, there are several ways to get an alias
555 * to a shared TARG. Such an alias will change randomly and unpredictably.
556 * We avoid doing this until we can think of a Better Way.
561 #ifdef USE_BROKEN_PAD_RESET
565 if (AvARRAY(PL_comppad) != PL_curpad)
566 croak("panic: pad_reset curpad");
568 DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx reset\n",
569 (unsigned long) thr, (unsigned long) PL_curpad));
571 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx reset\n",
572 (unsigned long) PL_curpad));
573 #endif /* USE_THREADS */
574 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
575 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
576 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
577 SvPADTMP_off(PL_curpad[po]);
579 PL_padix = PL_padix_floor;
582 PL_pad_reset_pending = FALSE;
586 /* find_threadsv is not reentrant */
588 find_threadsv(const char *name)
594 /* We currently only handle names of a single character */
595 p = strchr(PL_threadsv_names, *name);
598 key = p - PL_threadsv_names;
599 MUTEX_LOCK(&thr->mutex);
600 svp = av_fetch(thr->threadsv, key, FALSE);
602 MUTEX_UNLOCK(&thr->mutex);
604 SV *sv = NEWSV(0, 0);
605 av_store(thr->threadsv, key, sv);
606 thr->threadsvp = AvARRAY(thr->threadsv);
607 MUTEX_UNLOCK(&thr->mutex);
609 * Some magic variables used to be automagically initialised
610 * in gv_fetchpv. Those which are now per-thread magicals get
611 * initialised here instead.
617 sv_setpv(sv, "\034");
618 sv_magic(sv, 0, 0, name, 1);
623 PL_sawampersand = TRUE;
637 /* XXX %! tied to Errno.pm needs to be added here.
638 * See gv_fetchpv(). */
642 sv_magic(sv, 0, 0, name, 1);
644 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
645 "find_threadsv: new SV %p for $%s%c\n",
646 sv, (*name < 32) ? "^" : "",
647 (*name < 32) ? toCTRL(*name) : *name));
651 #endif /* USE_THREADS */
658 register OP *kid, *nextkid;
660 if (!o || o->op_seq == (U16)-1)
663 if (o->op_flags & OPf_KIDS) {
664 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
665 nextkid = kid->op_sibling; /* Get before next freeing kid */
670 switch (o->op_type) {
672 o->op_targ = 0; /* Was holding old type, if any. */
675 o->op_targ = 0; /* Was holding hints. */
679 if (!(o->op_flags & OPf_SPECIAL))
683 o->op_targ = 0; /* Was holding index into thr->threadsv AV. */
685 #endif /* USE_THREADS */
687 if (!(o->op_flags & OPf_REF)
688 || (PL_check[o->op_type] != FUNC_NAME_TO_PTR(ck_ftst)))
694 SvREFCNT_dec(cGVOPo->op_gv);
698 Safefree(cCOPo->cop_label);
699 SvREFCNT_dec(cCOPo->cop_filegv);
700 if (cCOPo->cop_warnings != WARN_NONE && cCOPo->cop_warnings != WARN_ALL)
701 SvREFCNT_dec(cCOPo->cop_warnings);
704 SvREFCNT_dec(cSVOPo->op_sv);
710 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
714 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
715 SvREFCNT_dec(cSVOPo->op_sv);
717 Safefree(cPVOPo->op_pv);
720 op_free(cPMOPo->op_pmreplroot);
725 ReREFCNT_dec(cPMOPo->op_pmregexp);
730 pad_free(o->op_targ);
732 #ifdef PL_OP_SLAB_ALLOC
733 if ((char *) o == PL_OpPtr)
744 if (o->op_type != OP_NULL && o->op_type != OP_THREADSV && o->op_targ > 0)
745 pad_free(o->op_targ);
746 o->op_targ = o->op_type;
747 o->op_type = OP_NULL;
748 o->op_ppaddr = PL_ppaddr[OP_NULL];
751 /* Contextualizers */
753 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
763 /* establish postfix order */
764 if (cUNOPo->op_first) {
765 o->op_next = LINKLIST(cUNOPo->op_first);
766 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
768 kid->op_next = LINKLIST(kid->op_sibling);
783 if (o && o->op_flags & OPf_KIDS) {
784 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
793 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
795 if (ckWARN(WARN_SYNTAX)) {
796 line_t oldline = PL_curcop->cop_line;
798 if (PL_copline != NOLINE)
799 PL_curcop->cop_line = PL_copline;
800 warner(WARN_SYNTAX, "Found = in conditional, should be ==");
801 PL_curcop->cop_line = oldline;
812 /* assumes no premature commitment */
813 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
814 || o->op_type == OP_RETURN)
817 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
819 switch (o->op_type) {
821 if (o->op_private & OPpREPEAT_DOLIST)
822 null(((LISTOP*)cBINOPo->op_first)->op_first);
823 scalar(cBINOPo->op_first);
828 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
832 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
833 if (!kPMOP->op_pmreplroot)
834 deprecate("implicit split to @_");
842 if (o->op_flags & OPf_KIDS) {
843 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
849 kid = cLISTOPo->op_first;
851 while (kid = kid->op_sibling) {
857 WITH_THR(PL_curcop = &PL_compiling);
862 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
868 WITH_THR(PL_curcop = &PL_compiling);
881 /* assumes no premature commitment */
882 U8 want = o->op_flags & OPf_WANT;
883 if (!o || (want && want != OPf_WANT_SCALAR) || PL_error_count
884 || o->op_type == OP_RETURN)
887 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
889 switch (o->op_type) {
891 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
895 if (o->op_flags & OPf_STACKED)
899 if (o->op_private == 4)
970 if (!(o->op_private & OPpLVAL_INTRO))
971 useless = PL_op_desc[o->op_type];
978 if (!(o->op_private & OPpLVAL_INTRO) &&
979 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
980 useless = "a variable";
985 WITH_THR(PL_curcop = ((COP*)o)); /* for warning below */
992 if (ckWARN(WARN_VOID)) {
993 useless = "a constant";
994 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
996 else if (SvPOK(sv)) {
997 if (strnEQ(SvPVX(sv), "di", 2) ||
998 strnEQ(SvPVX(sv), "ds", 2) ||
999 strnEQ(SvPVX(sv), "ig", 2))
1004 null(o); /* don't execute a constant */
1005 SvREFCNT_dec(sv); /* don't even remember it */
1009 o->op_type = OP_PREINC; /* pre-increment is faster */
1010 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1014 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1015 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1021 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1026 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
1027 WITH_THR(PL_curcop = ((COP*)o)); /* for warning below */
1028 if (o->op_flags & OPf_STACKED)
1034 if (!(o->op_flags & OPf_KIDS))
1043 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1050 /* all requires must return a boolean value */
1051 o->op_flags &= ~OPf_WANT;
1054 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1055 if (!kPMOP->op_pmreplroot)
1056 deprecate("implicit split to @_");
1062 if (ckWARN(WARN_VOID))
1063 warner(WARN_VOID, "Useless use of %s in void context", useless);
1072 if (o && o->op_flags & OPf_KIDS) {
1073 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1084 /* assumes no premature commitment */
1085 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1086 || o->op_type == OP_RETURN)
1089 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1091 switch (o->op_type) {
1094 list(cBINOPo->op_first);
1099 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1107 if (!(o->op_flags & OPf_KIDS))
1109 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1110 list(cBINOPo->op_first);
1111 return gen_constant_list(o);
1118 kid = cLISTOPo->op_first;
1120 while (kid = kid->op_sibling) {
1121 if (kid->op_sibling)
1126 WITH_THR(PL_curcop = &PL_compiling);
1130 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1131 if (kid->op_sibling)
1136 WITH_THR(PL_curcop = &PL_compiling);
1139 /* all requires must return a boolean value */
1140 o->op_flags &= ~OPf_WANT;
1152 if (o->op_type == OP_LINESEQ ||
1153 o->op_type == OP_SCOPE ||
1154 o->op_type == OP_LEAVE ||
1155 o->op_type == OP_LEAVETRY)
1158 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1159 if (kid->op_sibling) {
1163 PL_curcop = &PL_compiling;
1165 o->op_flags &= ~OPf_PARENS;
1166 if (PL_hints & HINT_BLOCK_SCOPE)
1167 o->op_flags |= OPf_PARENS;
1170 o = newOP(OP_STUB, 0);
1175 modkids(OP *o, I32 type)
1178 if (o && o->op_flags & OPf_KIDS) {
1179 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1186 mod(OP *o, I32 type)
1193 if (!o || PL_error_count)
1196 switch (o->op_type) {
1201 if (!(o->op_private & (OPpCONST_ARYBASE)))
1203 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1204 PL_compiling.cop_arybase = (I32)SvIV(((SVOP*)PL_eval_start)->op_sv);
1208 SAVEI32(PL_compiling.cop_arybase);
1209 PL_compiling.cop_arybase = 0;
1211 else if (type == OP_REFGEN)
1214 croak("That use of $[ is unsupported");
1217 if (o->op_flags & OPf_PARENS)
1221 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1222 !(o->op_flags & OPf_STACKED)) {
1223 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1224 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1225 assert(cUNOPo->op_first->op_type == OP_NULL);
1226 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1232 /* grep, foreach, subcalls, refgen */
1233 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1235 yyerror(form("Can't modify %s in %s",
1236 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1237 ? "do block" : PL_op_desc[o->op_type]),
1238 type ? PL_op_desc[type] : "local"));
1252 case OP_RIGHT_SHIFT:
1261 if (!(o->op_flags & OPf_STACKED))
1267 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1273 if (!type && cUNOPo->op_first->op_type != OP_GV)
1274 croak("Can't localize through a reference");
1275 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1276 PL_modcount = 10000;
1277 return o; /* Treat \(@foo) like ordinary list. */
1281 if (scalar_mod_type(o, type))
1283 ref(cUNOPo->op_first, o->op_type);
1292 PL_modcount = 10000;
1295 if (!type && cUNOPo->op_first->op_type != OP_GV)
1296 croak("Can't localize through a reference");
1297 ref(cUNOPo->op_first, o->op_type);
1301 PL_hints |= HINT_BLOCK_SCOPE;
1311 PL_modcount = 10000;
1312 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1313 return o; /* Treat \(@foo) like ordinary list. */
1314 if (scalar_mod_type(o, type))
1320 croak("Can't localize lexical variable %s",
1321 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1326 PL_modcount++; /* XXX ??? */
1328 #endif /* USE_THREADS */
1334 if (type != OP_SASSIGN)
1338 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1344 pad_free(o->op_targ);
1345 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1346 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1347 if (o->op_flags & OPf_KIDS)
1348 mod(cBINOPo->op_first->op_sibling, type);
1353 ref(cBINOPo->op_first, o->op_type);
1354 if (type == OP_ENTERSUB &&
1355 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1356 o->op_private |= OPpLVAL_DEFER;
1363 if (o->op_flags & OPf_KIDS)
1364 mod(cLISTOPo->op_last, type);
1368 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1370 else if (!(o->op_flags & OPf_KIDS))
1372 if (o->op_targ != OP_LIST) {
1373 mod(cBINOPo->op_first, type);
1378 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1382 o->op_flags |= OPf_MOD;
1384 if (type == OP_AASSIGN || type == OP_SASSIGN)
1385 o->op_flags |= OPf_SPECIAL|OPf_REF;
1387 o->op_private |= OPpLVAL_INTRO;
1388 o->op_flags &= ~OPf_SPECIAL;
1389 PL_hints |= HINT_BLOCK_SCOPE;
1391 else if (type != OP_GREPSTART && type != OP_ENTERSUB)
1392 o->op_flags |= OPf_REF;
1397 scalar_mod_type(OP *o, I32 type)
1401 if (o->op_type == OP_RV2GV)
1425 case OP_RIGHT_SHIFT:
1444 is_handle_constructor(OP *o, I32 argnum)
1446 switch (o->op_type) {
1454 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1467 refkids(OP *o, I32 type)
1470 if (o && o->op_flags & OPf_KIDS) {
1471 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1478 ref(OP *o, I32 type)
1482 if (!o || PL_error_count)
1485 switch (o->op_type) {
1487 if ((type == OP_DEFINED || type == OP_LOCK) &&
1488 !(o->op_flags & OPf_STACKED)) {
1489 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1490 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1491 assert(cUNOPo->op_first->op_type == OP_NULL);
1492 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1493 o->op_flags |= OPf_SPECIAL;
1498 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1502 if (type == OP_DEFINED)
1503 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1504 ref(cUNOPo->op_first, o->op_type);
1507 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1508 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1509 : type == OP_RV2HV ? OPpDEREF_HV
1511 o->op_flags |= OPf_MOD;
1516 o->op_flags |= OPf_MOD; /* XXX ??? */
1521 o->op_flags |= OPf_REF;
1524 if (type == OP_DEFINED)
1525 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1526 ref(cUNOPo->op_first, o->op_type);
1531 o->op_flags |= OPf_REF;
1536 if (!(o->op_flags & OPf_KIDS))
1538 ref(cBINOPo->op_first, type);
1542 ref(cBINOPo->op_first, o->op_type);
1543 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1544 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1545 : type == OP_RV2HV ? OPpDEREF_HV
1547 o->op_flags |= OPf_MOD;
1555 if (!(o->op_flags & OPf_KIDS))
1557 ref(cLISTOPo->op_last, type);
1572 if (!o || PL_error_count)
1576 if (type == OP_LIST) {
1577 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1579 } else if (type == OP_UNDEF) {
1581 } else if (type != OP_PADSV &&
1584 type != OP_PUSHMARK)
1586 yyerror(form("Can't declare %s in my", PL_op_desc[o->op_type]));
1589 o->op_flags |= OPf_MOD;
1590 o->op_private |= OPpLVAL_INTRO;
1598 o->op_flags |= OPf_PARENS;
1603 bind_match(I32 type, OP *left, OP *right)
1608 if (ckWARN(WARN_UNSAFE) &&
1609 (left->op_type == OP_RV2AV ||
1610 left->op_type == OP_RV2HV ||
1611 left->op_type == OP_PADAV ||
1612 left->op_type == OP_PADHV)) {
1613 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1614 right->op_type == OP_TRANS)
1615 ? right->op_type : OP_MATCH];
1616 char *sample = ((left->op_type == OP_RV2AV ||
1617 left->op_type == OP_PADAV)
1618 ? "@array" : "%hash");
1620 "Applying %s to %s will act on scalar(%s)",
1621 desc, sample, sample);
1624 if (right->op_type == OP_MATCH ||
1625 right->op_type == OP_SUBST ||
1626 right->op_type == OP_TRANS) {
1627 right->op_flags |= OPf_STACKED;
1628 if (right->op_type != OP_MATCH)
1629 left = mod(left, right->op_type);
1630 if (right->op_type == OP_TRANS)
1631 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1633 o = prepend_elem(right->op_type, scalar(left), right);
1635 return newUNOP(OP_NOT, 0, scalar(o));
1639 return bind_match(type, left,
1640 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1648 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1649 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1656 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1657 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1658 o->op_type = OP_LEAVE;
1659 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1662 if (o->op_type == OP_LINESEQ) {
1664 o->op_type = OP_SCOPE;
1665 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1666 kid = ((LISTOP*)o)->op_first;
1667 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE){
1668 SvREFCNT_dec(((COP*)kid)->cop_filegv);
1673 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1683 SAVESPTR(GvHV(PL_hintgv));
1684 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1685 SAVEFREESV(GvHV(PL_hintgv));
1689 block_start(int full)
1692 int retval = PL_savestack_ix;
1694 SAVEI32(PL_comppad_name_floor);
1696 if ((PL_comppad_name_fill = AvFILLp(PL_comppad_name)) > 0)
1697 PL_comppad_name_floor = PL_comppad_name_fill;
1699 PL_comppad_name_floor = 0;
1701 SAVEI32(PL_min_intro_pending);
1702 SAVEI32(PL_max_intro_pending);
1703 PL_min_intro_pending = 0;
1704 SAVEI32(PL_comppad_name_fill);
1705 SAVEI32(PL_padix_floor);
1706 PL_padix_floor = PL_padix;
1707 PL_pad_reset_pending = FALSE;
1709 PL_hints &= ~HINT_BLOCK_SCOPE;
1710 SAVEPPTR(PL_compiling.cop_warnings);
1711 if (PL_compiling.cop_warnings != WARN_ALL &&
1712 PL_compiling.cop_warnings != WARN_NONE) {
1713 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1714 SAVEFREESV(PL_compiling.cop_warnings) ;
1722 block_end(I32 floor, OP *seq)
1725 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1726 OP* retval = scalarseq(seq);
1728 PL_pad_reset_pending = FALSE;
1729 PL_compiling.op_private = PL_hints;
1731 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1732 pad_leavemy(PL_comppad_name_fill);
1741 OP *o = newOP(OP_THREADSV, 0);
1742 o->op_targ = find_threadsv("_");
1745 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1746 #endif /* USE_THREADS */
1756 PL_eval_root = newUNOP(OP_LEAVEEVAL, ((PL_in_eval & 4) ? OPf_SPECIAL : 0), o);
1757 PL_eval_start = linklist(PL_eval_root);
1758 PL_eval_root->op_next = 0;
1759 peep(PL_eval_start);
1764 PL_main_root = scope(sawparens(scalarvoid(o)));
1765 PL_curcop = &PL_compiling;
1766 PL_main_start = LINKLIST(PL_main_root);
1767 PL_main_root->op_next = 0;
1768 peep(PL_main_start);
1771 /* Register with debugger */
1773 CV *cv = perl_get_cv("DB::postponed", FALSE);
1777 XPUSHs((SV*)PL_compiling.cop_filegv);
1779 perl_call_sv((SV*)cv, G_DISCARD);
1786 localize(OP *o, I32 lex)
1788 if (o->op_flags & OPf_PARENS)
1792 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
1794 for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ;
1795 if (*s == ';' || *s == '=')
1796 warner(WARN_PARENTHESIS, "Parentheses missing around \"%s\" list",
1797 lex ? "my" : "local");
1801 PL_in_my_stash = Nullhv;
1805 return mod(o, OP_NULL); /* a bit kludgey */
1811 if (o->op_type == OP_LIST) {
1814 o2 = newOP(OP_THREADSV, 0);
1815 o2->op_targ = find_threadsv(";");
1817 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1818 #endif /* USE_THREADS */
1819 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1825 fold_constants(register OP *o)
1829 I32 type = o->op_type;
1832 if (PL_opargs[type] & OA_RETSCALAR)
1834 if (PL_opargs[type] & OA_TARGET)
1835 o->op_targ = pad_alloc(type, SVs_PADTMP);
1837 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
1838 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1840 if (!(PL_opargs[type] & OA_FOLDCONST))
1855 if (o->op_private & OPpLOCALE)
1860 goto nope; /* Don't try to run w/ errors */
1862 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1863 if (curop->op_type != OP_CONST &&
1864 curop->op_type != OP_LIST &&
1865 curop->op_type != OP_SCALAR &&
1866 curop->op_type != OP_NULL &&
1867 curop->op_type != OP_PUSHMARK) {
1872 curop = LINKLIST(o);
1876 sv = *(PL_stack_sp--);
1877 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1878 pad_swipe(o->op_targ);
1879 else if (SvTEMP(sv)) { /* grab mortal temp? */
1880 (void)SvREFCNT_inc(sv);
1884 if (type == OP_RV2GV)
1885 return newGVOP(OP_GV, 0, (GV*)sv);
1887 /* try to smush double to int, but don't smush -2.0 to -2 */
1888 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
1892 if ((double)iv == SvNV(sv)) {
1897 SvIOK_off(sv); /* undo SvIV() damage */
1899 return newSVOP(OP_CONST, 0, sv);
1903 if (!(PL_opargs[type] & OA_OTHERINT))
1906 if (!(PL_hints & HINT_INTEGER)) {
1907 if (type == OP_DIVIDE || !(o->op_flags & OPf_KIDS))
1910 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
1911 if (curop->op_type == OP_CONST) {
1912 if (SvIOK(((SVOP*)curop)->op_sv))
1916 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
1920 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
1927 gen_constant_list(register OP *o)
1931 I32 oldtmps_floor = PL_tmps_floor;
1935 return o; /* Don't attempt to run with errors */
1937 PL_op = curop = LINKLIST(o);
1943 PL_tmps_floor = oldtmps_floor;
1945 o->op_type = OP_RV2AV;
1946 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
1947 curop = ((UNOP*)o)->op_first;
1948 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
1955 convert(I32 type, I32 flags, OP *o)
1960 if (!o || o->op_type != OP_LIST)
1961 o = newLISTOP(OP_LIST, 0, o, Nullop);
1963 o->op_flags &= ~OPf_WANT;
1965 if (!(PL_opargs[type] & OA_MARK))
1966 null(cLISTOPo->op_first);
1969 o->op_ppaddr = PL_ppaddr[type];
1970 o->op_flags |= flags;
1972 o = CHECKOP(type, o);
1973 if (o->op_type != type)
1976 if (cLISTOPo->op_children < 7) {
1977 /* XXX do we really need to do this if we're done appending?? */
1978 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1980 cLISTOPo->op_last = last; /* in case check substituted last arg */
1983 return fold_constants(o);
1986 /* List constructors */
1989 append_elem(I32 type, OP *first, OP *last)
1997 if (first->op_type != type || type==OP_LIST && first->op_flags & OPf_PARENS)
1998 return newLISTOP(type, 0, first, last);
2000 if (first->op_flags & OPf_KIDS)
2001 ((LISTOP*)first)->op_last->op_sibling = last;
2003 first->op_flags |= OPf_KIDS;
2004 ((LISTOP*)first)->op_first = last;
2006 ((LISTOP*)first)->op_last = last;
2007 ((LISTOP*)first)->op_children++;
2012 append_list(I32 type, LISTOP *first, LISTOP *last)
2020 if (first->op_type != type)
2021 return prepend_elem(type, (OP*)first, (OP*)last);
2023 if (last->op_type != type)
2024 return append_elem(type, (OP*)first, (OP*)last);
2026 first->op_last->op_sibling = last->op_first;
2027 first->op_last = last->op_last;
2028 first->op_children += last->op_children;
2029 if (first->op_children)
2030 first->op_flags |= OPf_KIDS;
2032 #ifdef PL_OP_SLAB_ALLOC
2040 prepend_elem(I32 type, OP *first, OP *last)
2048 if (last->op_type == type) {
2049 if (type == OP_LIST) { /* already a PUSHMARK there */
2050 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2051 ((LISTOP*)last)->op_first->op_sibling = first;
2054 if (!(last->op_flags & OPf_KIDS)) {
2055 ((LISTOP*)last)->op_last = first;
2056 last->op_flags |= OPf_KIDS;
2058 first->op_sibling = ((LISTOP*)last)->op_first;
2059 ((LISTOP*)last)->op_first = first;
2061 ((LISTOP*)last)->op_children++;
2065 return newLISTOP(type, 0, first, last);
2073 return newOP(OP_STUB, 0);
2079 if (!o || o->op_type != OP_LIST)
2080 o = newLISTOP(OP_LIST, 0, o, Nullop);
2086 newLISTOP(I32 type, I32 flags, OP *first, OP *last)
2090 NewOp(1101, listop, 1, LISTOP);
2092 listop->op_type = type;
2093 listop->op_ppaddr = PL_ppaddr[type];
2094 listop->op_children = (first != 0) + (last != 0);
2095 listop->op_flags = flags;
2099 else if (!first && last)
2102 first->op_sibling = last;
2103 listop->op_first = first;
2104 listop->op_last = last;
2105 if (type == OP_LIST) {
2107 pushop = newOP(OP_PUSHMARK, 0);
2108 pushop->op_sibling = first;
2109 listop->op_first = pushop;
2110 listop->op_flags |= OPf_KIDS;
2112 listop->op_last = pushop;
2114 else if (listop->op_children)
2115 listop->op_flags |= OPf_KIDS;
2121 newOP(I32 type, I32 flags)
2124 NewOp(1101, o, 1, OP);
2126 o->op_ppaddr = PL_ppaddr[type];
2127 o->op_flags = flags;
2130 o->op_private = 0 + (flags >> 8);
2131 if (PL_opargs[type] & OA_RETSCALAR)
2133 if (PL_opargs[type] & OA_TARGET)
2134 o->op_targ = pad_alloc(type, SVs_PADTMP);
2135 return CHECKOP(type, o);
2139 newUNOP(I32 type, I32 flags, OP *first)
2144 first = newOP(OP_STUB, 0);
2145 if (PL_opargs[type] & OA_MARK)
2146 first = force_list(first);
2148 NewOp(1101, unop, 1, UNOP);
2149 unop->op_type = type;
2150 unop->op_ppaddr = PL_ppaddr[type];
2151 unop->op_first = first;
2152 unop->op_flags = flags | OPf_KIDS;
2153 unop->op_private = 1 | (flags >> 8);
2154 unop = (UNOP*) CHECKOP(type, unop);
2158 return fold_constants((OP *) unop);
2162 newBINOP(I32 type, I32 flags, OP *first, OP *last)
2165 NewOp(1101, binop, 1, BINOP);
2168 first = newOP(OP_NULL, 0);
2170 binop->op_type = type;
2171 binop->op_ppaddr = PL_ppaddr[type];
2172 binop->op_first = first;
2173 binop->op_flags = flags | OPf_KIDS;
2176 binop->op_private = 1 | (flags >> 8);
2179 binop->op_private = 2 | (flags >> 8);
2180 first->op_sibling = last;
2183 binop = (BINOP*)CHECKOP(type, binop);
2187 binop->op_last = binop->op_first->op_sibling;
2189 return fold_constants((OP *)binop);
2193 utf8compare(const void *a, const void *b)
2196 for (i = 0; i < 10; i++) {
2197 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2199 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2206 pmtrans(OP *o, OP *expr, OP *repl)
2208 SV *tstr = ((SVOP*)expr)->op_sv;
2209 SV *rstr = ((SVOP*)repl)->op_sv;
2212 register U8 *t = (U8*)SvPV(tstr, tlen);
2213 register U8 *r = (U8*)SvPV(rstr, rlen);
2219 register short *tbl;
2221 complement = o->op_private & OPpTRANS_COMPLEMENT;
2222 del = o->op_private & OPpTRANS_DELETE;
2223 squash = o->op_private & OPpTRANS_SQUASH;
2225 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2226 SV* listsv = newSVpvn("# comment\n",10);
2228 U8* tend = t + tlen;
2229 U8* rend = r + rlen;
2245 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2246 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2252 New(1109, cp, tlen, U8*);
2254 transv = newSVpvn("",0);
2263 qsort(cp, i, sizeof(U8*), utf8compare);
2264 for (j = 0; j < i; j++) {
2266 UV val = utf8_to_uv(s, &ulen);
2268 diff = val - nextmin;
2270 t = uv_to_utf8(tmpbuf,nextmin);
2271 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2273 t = uv_to_utf8(tmpbuf, val - 1);
2274 sv_catpvn(transv, "\377", 1);
2275 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2279 val = utf8_to_uv(s+1, &ulen);
2283 t = uv_to_utf8(tmpbuf,nextmin);
2284 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2285 t = uv_to_utf8(tmpbuf, 0x7fffffff);
2286 sv_catpvn(transv, "\377", 1);
2287 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2288 t = (U8*)SvPVX(transv);
2289 tlen = SvCUR(transv);
2292 else if (!rlen && !del) {
2293 r = t; rlen = tlen; rend = tend;
2296 if (to_utf && from_utf) { /* only counting characters */
2297 if (t == r || (tlen == rlen && memEQ(t, r, tlen)))
2298 o->op_private |= OPpTRANS_IDENTICAL;
2300 else { /* straight latin-1 translation */
2301 if (tlen == 4 && memEQ(t, "\0\377\303\277", 4) &&
2302 rlen == 4 && memEQ(r, "\0\377\303\277", 4))
2303 o->op_private |= OPpTRANS_IDENTICAL;
2307 while (t < tend || tfirst <= tlast) {
2308 /* see if we need more "t" chars */
2309 if (tfirst > tlast) {
2310 tfirst = (I32)utf8_to_uv(t, &ulen);
2312 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2313 tlast = (I32)utf8_to_uv(++t, &ulen);
2320 /* now see if we need more "r" chars */
2321 if (rfirst > rlast) {
2323 rfirst = (I32)utf8_to_uv(r, &ulen);
2325 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2326 rlast = (I32)utf8_to_uv(++r, &ulen);
2335 rfirst = rlast = 0xffffffff;
2339 /* now see which range will peter our first, if either. */
2340 tdiff = tlast - tfirst;
2341 rdiff = rlast - rfirst;
2348 if (rfirst == 0xffffffff) {
2349 diff = tdiff; /* oops, pretend rdiff is infinite */
2351 sv_catpvf(listsv, "%04x\t%04x\tXXXX\n", tfirst, tlast);
2353 sv_catpvf(listsv, "%04x\t\tXXXX\n", tfirst);
2357 sv_catpvf(listsv, "%04x\t%04x\t%04x\n", tfirst, tfirst + diff, rfirst);
2359 sv_catpvf(listsv, "%04x\t\t%04x\n", tfirst, rfirst);
2361 if (rfirst + diff > max)
2362 max = rfirst + diff;
2367 else if (rfirst <= 0x800)
2368 grows |= (tfirst < 0x80);
2369 else if (rfirst <= 0x10000)
2370 grows |= (tfirst < 0x800);
2371 else if (rfirst <= 0x200000)
2372 grows |= (tfirst < 0x10000);
2373 else if (rfirst <= 0x4000000)
2374 grows |= (tfirst < 0x200000);
2375 else if (rfirst <= 0x80000000)
2376 grows |= (tfirst < 0x4000000);
2388 else if (max > 0xff)
2393 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2394 SvREFCNT_dec(listsv);
2396 SvREFCNT_dec(transv);
2398 if (!del && havefinal)
2399 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, newSViv((IV)final), 0);
2401 if (grows && to_utf)
2402 o->op_private |= OPpTRANS_GROWS;
2409 tbl = (short*)cPVOPo->op_pv;
2411 Zero(tbl, 256, short);
2412 for (i = 0; i < tlen; i++)
2414 for (i = 0, j = 0; i < 256; i++) {
2430 if (!rlen && !del) {
2433 o->op_private |= OPpTRANS_IDENTICAL;
2435 for (i = 0; i < 256; i++)
2437 for (i = 0, j = 0; i < tlen; i++,j++) {
2440 if (tbl[t[i]] == -1)
2446 if (tbl[t[i]] == -1)
2457 newPMOP(I32 type, I32 flags)
2462 NewOp(1101, pmop, 1, PMOP);
2463 pmop->op_type = type;
2464 pmop->op_ppaddr = PL_ppaddr[type];
2465 pmop->op_flags = flags;
2466 pmop->op_private = 0 | (flags >> 8);
2468 if (PL_hints & HINT_RE_TAINT)
2469 pmop->op_pmpermflags |= PMf_RETAINT;
2470 if (PL_hints & HINT_LOCALE)
2471 pmop->op_pmpermflags |= PMf_LOCALE;
2472 pmop->op_pmflags = pmop->op_pmpermflags;
2474 /* link into pm list */
2475 if (type != OP_TRANS && PL_curstash) {
2476 pmop->op_pmnext = HvPMROOT(PL_curstash);
2477 HvPMROOT(PL_curstash) = pmop;
2484 pmruntime(OP *o, OP *expr, OP *repl)
2489 I32 repl_has_vars = 0;
2491 if (o->op_type == OP_TRANS)
2492 return pmtrans(o, expr, repl);
2494 PL_hints |= HINT_BLOCK_SCOPE;
2497 if (expr->op_type == OP_CONST) {
2499 SV *pat = ((SVOP*)expr)->op_sv;
2500 char *p = SvPV(pat, plen);
2501 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2502 sv_setpvn(pat, "\\s+", 3);
2503 p = SvPV(pat, plen);
2504 pm->op_pmflags |= PMf_SKIPWHITE;
2506 pm->op_pmregexp = CALLREGCOMP(p, p + plen, pm);
2507 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2508 pm->op_pmflags |= PMf_WHITE;
2512 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2513 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2515 : OP_REGCMAYBE),0,expr);
2517 NewOp(1101, rcop, 1, LOGOP);
2518 rcop->op_type = OP_REGCOMP;
2519 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2520 rcop->op_first = scalar(expr);
2521 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2522 ? (OPf_SPECIAL | OPf_KIDS)
2524 rcop->op_private = 1;
2527 /* establish postfix order */
2528 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2530 rcop->op_next = expr;
2531 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2534 rcop->op_next = LINKLIST(expr);
2535 expr->op_next = (OP*)rcop;
2538 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2543 if (pm->op_pmflags & PMf_EVAL) {
2545 if (PL_curcop->cop_line < PL_multi_end)
2546 PL_curcop->cop_line = PL_multi_end;
2549 else if (repl->op_type == OP_THREADSV
2550 && strchr("&`'123456789+",
2551 PL_threadsv_names[repl->op_targ]))
2555 #endif /* USE_THREADS */
2556 else if (repl->op_type == OP_CONST)
2560 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2561 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2563 if (curop->op_type == OP_THREADSV) {
2565 if (strchr("&`'123456789+", curop->op_private))
2569 if (curop->op_type == OP_GV) {
2570 GV *gv = ((GVOP*)curop)->op_gv;
2572 if (strchr("&`'123456789+", *GvENAME(gv)))
2575 #endif /* USE_THREADS */
2576 else if (curop->op_type == OP_RV2CV)
2578 else if (curop->op_type == OP_RV2SV ||
2579 curop->op_type == OP_RV2AV ||
2580 curop->op_type == OP_RV2HV ||
2581 curop->op_type == OP_RV2GV) {
2582 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2585 else if (curop->op_type == OP_PADSV ||
2586 curop->op_type == OP_PADAV ||
2587 curop->op_type == OP_PADHV ||
2588 curop->op_type == OP_PADANY) {
2591 else if (curop->op_type == OP_PUSHRE)
2592 ; /* Okay here, dangerous in newASSIGNOP */
2601 && (!pm->op_pmregexp
2602 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
2603 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2604 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2605 prepend_elem(o->op_type, scalar(repl), o);
2608 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
2609 pm->op_pmflags |= PMf_MAYBE_CONST;
2610 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2612 NewOp(1101, rcop, 1, LOGOP);
2613 rcop->op_type = OP_SUBSTCONT;
2614 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2615 rcop->op_first = scalar(repl);
2616 rcop->op_flags |= OPf_KIDS;
2617 rcop->op_private = 1;
2620 /* establish postfix order */
2621 rcop->op_next = LINKLIST(repl);
2622 repl->op_next = (OP*)rcop;
2624 pm->op_pmreplroot = scalar((OP*)rcop);
2625 pm->op_pmreplstart = LINKLIST(rcop);
2634 newSVOP(I32 type, I32 flags, SV *sv)
2637 NewOp(1101, svop, 1, SVOP);
2638 svop->op_type = type;
2639 svop->op_ppaddr = PL_ppaddr[type];
2641 svop->op_next = (OP*)svop;
2642 svop->op_flags = flags;
2643 if (PL_opargs[type] & OA_RETSCALAR)
2645 if (PL_opargs[type] & OA_TARGET)
2646 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2647 return CHECKOP(type, svop);
2651 newGVOP(I32 type, I32 flags, GV *gv)
2655 NewOp(1101, gvop, 1, GVOP);
2656 gvop->op_type = type;
2657 gvop->op_ppaddr = PL_ppaddr[type];
2658 gvop->op_gv = (GV*)SvREFCNT_inc(gv);
2659 gvop->op_next = (OP*)gvop;
2660 gvop->op_flags = flags;
2661 if (PL_opargs[type] & OA_RETSCALAR)
2663 if (PL_opargs[type] & OA_TARGET)
2664 gvop->op_targ = pad_alloc(type, SVs_PADTMP);
2665 return CHECKOP(type, gvop);
2669 newPVOP(I32 type, I32 flags, char *pv)
2672 NewOp(1101, pvop, 1, PVOP);
2673 pvop->op_type = type;
2674 pvop->op_ppaddr = PL_ppaddr[type];
2676 pvop->op_next = (OP*)pvop;
2677 pvop->op_flags = flags;
2678 if (PL_opargs[type] & OA_RETSCALAR)
2680 if (PL_opargs[type] & OA_TARGET)
2681 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2682 return CHECKOP(type, pvop);
2691 save_hptr(&PL_curstash);
2692 save_item(PL_curstname);
2697 name = SvPV(sv, len);
2698 PL_curstash = gv_stashpvn(name,len,TRUE);
2699 sv_setpvn(PL_curstname, name, len);
2703 sv_setpv(PL_curstname,"<none>");
2704 PL_curstash = Nullhv;
2706 PL_hints |= HINT_BLOCK_SCOPE;
2707 PL_copline = NOLINE;
2712 utilize(int aver, I32 floor, OP *version, OP *id, OP *arg)
2721 if (id->op_type != OP_CONST)
2722 croak("Module name must be constant");
2726 if(version != Nullop) {
2727 SV *vesv = ((SVOP*)version)->op_sv;
2729 if (arg == Nullop && !SvNIOK(vesv)) {
2736 if (version->op_type != OP_CONST || !SvNIOK(vesv))
2737 croak("Version number must be constant number");
2739 /* Make copy of id so we don't free it twice */
2740 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2742 /* Fake up a method call to VERSION */
2743 meth = newSVOP(OP_CONST, 0, newSVpvn("VERSION", 7));
2744 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2745 append_elem(OP_LIST,
2746 prepend_elem(OP_LIST, pack, list(version)),
2747 newUNOP(OP_METHOD, 0, meth)));
2751 /* Fake up an import/unimport */
2752 if (arg && arg->op_type == OP_STUB)
2753 imop = arg; /* no import on explicit () */
2754 else if(SvNIOK(((SVOP*)id)->op_sv)) {
2755 imop = Nullop; /* use 5.0; */
2758 /* Make copy of id so we don't free it twice */
2759 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2760 meth = newSVOP(OP_CONST, 0,
2762 ? newSVpvn("import", 6)
2763 : newSVpvn("unimport", 8)
2765 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2766 append_elem(OP_LIST,
2767 prepend_elem(OP_LIST, pack, list(arg)),
2768 newUNOP(OP_METHOD, 0, meth)));
2771 /* Fake up a require, handle override, if any */
2772 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
2773 if (!(gv && GvIMPORTED_CV(gv)))
2774 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
2776 if (gv && GvIMPORTED_CV(gv)) {
2777 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2778 append_elem(OP_LIST, id,
2779 scalar(newUNOP(OP_RV2CV, 0,
2784 rqop = newUNOP(OP_REQUIRE, 0, id);
2787 /* Fake up the BEGIN {}, which does its thing immediately. */
2789 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2791 append_elem(OP_LINESEQ,
2792 append_elem(OP_LINESEQ,
2793 newSTATEOP(0, Nullch, rqop),
2794 newSTATEOP(0, Nullch, veop)),
2795 newSTATEOP(0, Nullch, imop) ));
2797 PL_copline = NOLINE;
2807 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
2808 if (!(gv && GvIMPORTED_CV(gv)))
2809 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
2811 if (gv && GvIMPORTED_CV(gv)) {
2812 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2813 append_elem(OP_LIST, term,
2814 scalar(newUNOP(OP_RV2CV, 0,
2819 doop = newUNOP(OP_DOFILE, 0, scalar(term));
2825 newSLICEOP(I32 flags, OP *subscript, OP *listval)
2827 return newBINOP(OP_LSLICE, flags,
2828 list(force_list(subscript)),
2829 list(force_list(listval)) );
2833 list_assignment(register OP *o)
2838 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
2839 o = cUNOPo->op_first;
2841 if (o->op_type == OP_COND_EXPR) {
2842 I32 t = list_assignment(cCONDOPo->op_first->op_sibling);
2843 I32 f = list_assignment(cCONDOPo->op_first->op_sibling->op_sibling);
2848 yyerror("Assignment to both a list and a scalar");
2852 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
2853 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
2854 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
2857 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
2860 if (o->op_type == OP_RV2SV)
2867 newASSIGNOP(I32 flags, OP *left, I32 optype, OP *right)
2872 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
2873 return newLOGOP(optype, 0,
2874 mod(scalar(left), optype),
2875 newUNOP(OP_SASSIGN, 0, scalar(right)));
2878 return newBINOP(optype, OPf_STACKED,
2879 mod(scalar(left), optype), scalar(right));
2883 if (list_assignment(left)) {
2886 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
2887 left = mod(left, OP_AASSIGN);
2895 o = newBINOP(OP_AASSIGN, flags,
2896 list(force_list(right)),
2897 list(force_list(left)) );
2898 o->op_private = 0 | (flags >> 8);
2899 if (!(left->op_private & OPpLVAL_INTRO)) {
2903 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2904 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2905 if (curop->op_type == OP_GV) {
2906 GV *gv = ((GVOP*)curop)->op_gv;
2907 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
2909 SvCUR(gv) = PL_generation;
2911 else if (curop->op_type == OP_PADSV ||
2912 curop->op_type == OP_PADAV ||
2913 curop->op_type == OP_PADHV ||
2914 curop->op_type == OP_PADANY) {
2915 SV **svp = AvARRAY(PL_comppad_name);
2916 SV *sv = svp[curop->op_targ];
2917 if (SvCUR(sv) == PL_generation)
2919 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
2921 else if (curop->op_type == OP_RV2CV)
2923 else if (curop->op_type == OP_RV2SV ||
2924 curop->op_type == OP_RV2AV ||
2925 curop->op_type == OP_RV2HV ||
2926 curop->op_type == OP_RV2GV) {
2927 if (lastop->op_type != OP_GV) /* funny deref? */
2930 else if (curop->op_type == OP_PUSHRE) {
2931 if (((PMOP*)curop)->op_pmreplroot) {
2932 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
2933 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
2935 SvCUR(gv) = PL_generation;
2944 o->op_private = OPpASSIGN_COMMON;
2946 if (right && right->op_type == OP_SPLIT) {
2948 if ((tmpop = ((LISTOP*)right)->op_first) &&
2949 tmpop->op_type == OP_PUSHRE)
2951 PMOP *pm = (PMOP*)tmpop;
2952 if (left->op_type == OP_RV2AV &&
2953 !(left->op_private & OPpLVAL_INTRO) &&
2954 !(o->op_private & OPpASSIGN_COMMON) )
2956 tmpop = ((UNOP*)left)->op_first;
2957 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
2958 pm->op_pmreplroot = (OP*)((GVOP*)tmpop)->op_gv;
2959 pm->op_pmflags |= PMf_ONCE;
2960 tmpop = cUNOPo->op_first; /* to list (nulled) */
2961 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
2962 tmpop->op_sibling = Nullop; /* don't free split */
2963 right->op_next = tmpop->op_next; /* fix starting loc */
2964 op_free(o); /* blow off assign */
2965 right->op_flags &= ~OPf_WANT;
2966 /* "I don't know and I don't care." */
2971 if (PL_modcount < 10000 &&
2972 ((LISTOP*)right)->op_last->op_type == OP_CONST)
2974 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
2976 sv_setiv(sv, PL_modcount+1);
2984 right = newOP(OP_UNDEF, 0);
2985 if (right->op_type == OP_READLINE) {
2986 right->op_flags |= OPf_STACKED;
2987 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
2990 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
2991 o = newBINOP(OP_SASSIGN, flags,
2992 scalar(right), mod(scalar(left), OP_SASSIGN) );
3004 newSTATEOP(I32 flags, char *label, OP *o)
3007 U32 seq = intro_my();
3010 NewOp(1101, cop, 1, COP);
3011 if (PERLDB_LINE && PL_curcop->cop_line && PL_curstash != PL_debstash) {
3012 cop->op_type = OP_DBSTATE;
3013 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3016 cop->op_type = OP_NEXTSTATE;
3017 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3019 cop->op_flags = flags;
3020 cop->op_private = (PL_hints & HINT_UTF8);
3022 cop->op_private |= NATIVE_HINTS;
3024 PL_compiling.op_private = cop->op_private;
3025 cop->op_next = (OP*)cop;
3028 cop->cop_label = label;
3029 PL_hints |= HINT_BLOCK_SCOPE;
3032 cop->cop_arybase = PL_curcop->cop_arybase;
3033 if (PL_curcop->cop_warnings == WARN_NONE
3034 || PL_curcop->cop_warnings == WARN_ALL)
3035 cop->cop_warnings = PL_curcop->cop_warnings ;
3037 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3040 if (PL_copline == NOLINE)
3041 cop->cop_line = PL_curcop->cop_line;
3043 cop->cop_line = PL_copline;
3044 PL_copline = NOLINE;
3046 cop->cop_filegv = (GV*)SvREFCNT_inc(PL_curcop->cop_filegv);
3047 cop->cop_stash = PL_curstash;
3049 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3050 SV **svp = av_fetch(GvAV(PL_curcop->cop_filegv),(I32)cop->cop_line, FALSE);
3051 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3052 (void)SvIOK_on(*svp);
3054 SvSTASH(*svp) = (HV*)cop;
3058 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3061 /* "Introduce" my variables to visible status. */
3069 if (! PL_min_intro_pending)
3070 return PL_cop_seqmax;
3072 svp = AvARRAY(PL_comppad_name);
3073 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3074 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3075 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3076 SvNVX(sv) = (double)PL_cop_seqmax;
3079 PL_min_intro_pending = 0;
3080 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3081 return PL_cop_seqmax++;
3085 newLOGOP(I32 type, I32 flags, OP *first, OP *other)
3087 return new_logop(type, flags, &first, &other);
3091 new_logop(I32 type, I32 flags, OP** firstp, OP** otherp)
3096 OP *first = *firstp;
3097 OP *other = *otherp;
3099 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3100 return newBINOP(type, flags, scalar(first), scalar(other));
3102 scalarboolean(first);
3103 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3104 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3105 if (type == OP_AND || type == OP_OR) {
3111 first = *firstp = cUNOPo->op_first;
3113 first->op_next = o->op_next;
3114 cUNOPo->op_first = Nullop;
3118 if (first->op_type == OP_CONST) {
3119 if (ckWARN(WARN_PRECEDENCE) && (first->op_private & OPpCONST_BARE))
3120 warner(WARN_PRECEDENCE, "Probable precedence problem on %s",
3122 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3133 else if (first->op_type == OP_WANTARRAY) {
3139 else if (ckWARN(WARN_UNSAFE) && (first->op_flags & OPf_KIDS)) {
3140 OP *k1 = ((UNOP*)first)->op_first;
3141 OP *k2 = k1->op_sibling;
3143 switch (first->op_type)
3146 if (k2 && k2->op_type == OP_READLINE
3147 && (k2->op_flags & OPf_STACKED)
3148 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3149 warnop = k2->op_type;
3153 if (k1->op_type == OP_READDIR
3154 || k1->op_type == OP_GLOB
3155 || k1->op_type == OP_EACH)
3156 warnop = k1->op_type;
3160 line_t oldline = PL_curcop->cop_line;
3161 PL_curcop->cop_line = PL_copline;
3163 "Value of %s%s can be \"0\"; test with defined()",
3165 ((warnop == OP_READLINE || warnop == OP_GLOB)
3166 ? " construct" : "() operator"));
3167 PL_curcop->cop_line = oldline;
3174 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3175 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3177 NewOp(1101, logop, 1, LOGOP);
3179 logop->op_type = type;
3180 logop->op_ppaddr = PL_ppaddr[type];
3181 logop->op_first = first;
3182 logop->op_flags = flags | OPf_KIDS;
3183 logop->op_other = LINKLIST(other);
3184 logop->op_private = 1 | (flags >> 8);
3186 /* establish postfix order */
3187 logop->op_next = LINKLIST(first);
3188 first->op_next = (OP*)logop;
3189 first->op_sibling = other;
3191 o = newUNOP(OP_NULL, 0, (OP*)logop);
3198 newCONDOP(I32 flags, OP *first, OP *trueop, OP *falseop)
3205 return newLOGOP(OP_AND, 0, first, trueop);
3207 return newLOGOP(OP_OR, 0, first, falseop);
3209 scalarboolean(first);
3210 if (first->op_type == OP_CONST) {
3211 if (SvTRUE(((SVOP*)first)->op_sv)) {
3222 else if (first->op_type == OP_WANTARRAY) {
3226 NewOp(1101, condop, 1, CONDOP);
3228 condop->op_type = OP_COND_EXPR;
3229 condop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3230 condop->op_first = first;
3231 condop->op_flags = flags | OPf_KIDS;
3232 condop->op_true = LINKLIST(trueop);
3233 condop->op_false = LINKLIST(falseop);
3234 condop->op_private = 1 | (flags >> 8);
3236 /* establish postfix order */
3237 condop->op_next = LINKLIST(first);
3238 first->op_next = (OP*)condop;
3240 first->op_sibling = trueop;
3241 trueop->op_sibling = falseop;
3242 o = newUNOP(OP_NULL, 0, (OP*)condop);
3244 trueop->op_next = o;
3245 falseop->op_next = o;
3251 newRANGE(I32 flags, OP *left, OP *right)
3259 NewOp(1101, condop, 1, CONDOP);
3261 condop->op_type = OP_RANGE;
3262 condop->op_ppaddr = PL_ppaddr[OP_RANGE];
3263 condop->op_first = left;
3264 condop->op_flags = OPf_KIDS;
3265 condop->op_true = LINKLIST(left);
3266 condop->op_false = LINKLIST(right);
3267 condop->op_private = 1 | (flags >> 8);
3269 left->op_sibling = right;
3271 condop->op_next = (OP*)condop;
3272 flip = newUNOP(OP_FLIP, flags, (OP*)condop);
3273 flop = newUNOP(OP_FLOP, 0, flip);
3274 o = newUNOP(OP_NULL, 0, flop);
3277 left->op_next = flip;
3278 right->op_next = flop;
3280 condop->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3281 sv_upgrade(PAD_SV(condop->op_targ), SVt_PVNV);
3282 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3283 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3285 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3286 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3289 if (!flip->op_private || !flop->op_private)
3290 linklist(o); /* blow off optimizer unless constant */
3296 newLOOPOP(I32 flags, I32 debuggable, OP *expr, OP *block)
3301 int once = block && block->op_flags & OPf_SPECIAL &&
3302 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3305 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3306 return block; /* do {} while 0 does once */
3307 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3308 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3309 expr = newUNOP(OP_DEFINED, 0,
3310 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3311 } else if (expr->op_flags & OPf_KIDS) {
3312 OP *k1 = ((UNOP*)expr)->op_first;
3313 OP *k2 = (k1) ? k1->op_sibling : NULL;
3314 switch (expr->op_type) {
3316 if (k2 && k2->op_type == OP_READLINE
3317 && (k2->op_flags & OPf_STACKED)
3318 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3319 expr = newUNOP(OP_DEFINED, 0, expr);
3323 if (k1->op_type == OP_READDIR
3324 || k1->op_type == OP_GLOB
3325 || k1->op_type == OP_EACH)
3326 expr = newUNOP(OP_DEFINED, 0, expr);
3332 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3333 o = new_logop(OP_AND, 0, &expr, &listop);
3336 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3338 if (once && o != listop)
3339 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3342 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3344 o->op_flags |= flags;
3346 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3351 newWHILEOP(I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3360 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3361 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3362 expr = newUNOP(OP_DEFINED, 0,
3363 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3364 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3365 OP *k1 = ((UNOP*)expr)->op_first;
3366 OP *k2 = (k1) ? k1->op_sibling : NULL;
3367 switch (expr->op_type) {
3369 if (k2 && k2->op_type == OP_READLINE
3370 && (k2->op_flags & OPf_STACKED)
3371 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3372 expr = newUNOP(OP_DEFINED, 0, expr);
3376 if (k1->op_type == OP_READDIR
3377 || k1->op_type == OP_GLOB
3378 || k1->op_type == OP_EACH)
3379 expr = newUNOP(OP_DEFINED, 0, expr);
3385 block = newOP(OP_NULL, 0);
3388 next = LINKLIST(cont);
3390 cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0));
3391 if ((line_t)whileline != NOLINE) {
3392 PL_copline = whileline;
3393 cont = append_elem(OP_LINESEQ, cont,
3394 newSTATEOP(0, Nullch, Nullop));
3398 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3399 redo = LINKLIST(listop);
3402 PL_copline = whileline;
3404 o = new_logop(OP_AND, 0, &expr, &listop);
3405 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3406 op_free(expr); /* oops, it's a while (0) */
3408 return Nullop; /* listop already freed by new_logop */
3411 ((LISTOP*)listop)->op_last->op_next = condop =
3412 (o == listop ? redo : LINKLIST(o));
3420 NewOp(1101,loop,1,LOOP);
3421 loop->op_type = OP_ENTERLOOP;
3422 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3423 loop->op_private = 0;
3424 loop->op_next = (OP*)loop;
3427 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3429 loop->op_redoop = redo;
3430 loop->op_lastop = o;
3433 loop->op_nextop = next;
3435 loop->op_nextop = o;
3437 o->op_flags |= flags;
3438 o->op_private |= (flags >> 8);
3443 newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3452 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3453 sv->op_type = OP_RV2GV;
3454 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3456 else if (sv->op_type == OP_PADSV) { /* private variable */
3457 padoff = sv->op_targ;
3461 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3462 padoff = sv->op_targ;
3463 iterflags |= OPf_SPECIAL;
3468 croak("Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3472 padoff = find_threadsv("_");
3473 iterflags |= OPf_SPECIAL;
3475 sv = newGVOP(OP_GV, 0, PL_defgv);
3478 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3479 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3480 iterflags |= OPf_STACKED;
3482 else if (expr->op_type == OP_NULL &&
3483 (expr->op_flags & OPf_KIDS) &&
3484 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3486 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3487 * set the STACKED flag to indicate that these values are to be
3488 * treated as min/max values by 'pp_iterinit'.
3490 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3491 CONDOP* range = (CONDOP*) flip->op_first;
3492 OP* left = range->op_first;
3493 OP* right = left->op_sibling;
3496 range->op_flags &= ~OPf_KIDS;
3497 range->op_first = Nullop;
3499 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3500 listop->op_first->op_next = range->op_true;
3501 left->op_next = range->op_false;
3502 right->op_next = (OP*)listop;
3503 listop->op_next = listop->op_first;
3506 expr = (OP*)(listop);
3508 iterflags |= OPf_STACKED;
3511 expr = mod(force_list(expr), OP_GREPSTART);
3515 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3516 append_elem(OP_LIST, expr, scalar(sv))));
3517 assert(!loop->op_next);
3518 #ifdef PL_OP_SLAB_ALLOC
3519 NewOp(1234,tmp,1,LOOP);
3520 Copy(loop,tmp,1,LOOP);
3523 Renew(loop, 1, LOOP);
3525 loop->op_targ = padoff;
3526 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3527 PL_copline = forline;
3528 return newSTATEOP(0, label, wop);
3532 newLOOPEX(I32 type, OP *label)
3538 if (type != OP_GOTO || label->op_type == OP_CONST) {
3539 /* "last()" means "last" */
3540 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3541 o = newOP(type, OPf_SPECIAL);
3543 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3544 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3550 if (label->op_type == OP_ENTERSUB)
3551 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3552 o = newUNOP(type, OPf_STACKED, label);
3554 PL_hints |= HINT_BLOCK_SCOPE;
3564 MUTEX_DESTROY(CvMUTEXP(cv));
3565 Safefree(CvMUTEXP(cv));
3568 #endif /* USE_THREADS */
3570 if (!CvXSUB(cv) && CvROOT(cv)) {
3572 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
3573 croak("Can't undef active subroutine");
3576 croak("Can't undef active subroutine");
3577 #endif /* USE_THREADS */
3580 SAVESPTR(PL_curpad);
3584 op_free(CvROOT(cv));
3585 CvROOT(cv) = Nullop;
3588 SvPOK_off((SV*)cv); /* forget prototype */
3590 SvREFCNT_dec(CvGV(cv));
3592 SvREFCNT_dec(CvOUTSIDE(cv));
3593 CvOUTSIDE(cv) = Nullcv;
3594 if (CvPADLIST(cv)) {
3595 /* may be during global destruction */
3596 if (SvREFCNT(CvPADLIST(cv))) {
3597 I32 i = AvFILLp(CvPADLIST(cv));
3599 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
3600 SV* sv = svp ? *svp : Nullsv;
3603 if (sv == (SV*)PL_comppad_name)
3604 PL_comppad_name = Nullav;
3605 else if (sv == (SV*)PL_comppad) {
3606 PL_comppad = Nullav;
3607 PL_curpad = Null(SV**);
3611 SvREFCNT_dec((SV*)CvPADLIST(cv));
3613 CvPADLIST(cv) = Nullav;
3617 #ifdef DEBUG_CLOSURES
3622 CV *outside = CvOUTSIDE(cv);
3623 AV* padlist = CvPADLIST(cv);
3630 PerlIO_printf(Perl_debug_log, "\tCV=0x%lx (%s), OUTSIDE=0x%lx (%s)\n",
3632 (CvANON(cv) ? "ANON"
3633 : (cv == PL_main_cv) ? "MAIN"
3634 : CvUNIQUE(cv) ? "UNIQUE"
3635 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
3638 : CvANON(outside) ? "ANON"
3639 : (outside == PL_main_cv) ? "MAIN"
3640 : CvUNIQUE(outside) ? "UNIQUE"
3641 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
3646 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
3647 pad = (AV*)*av_fetch(padlist, 1, FALSE);
3648 pname = AvARRAY(pad_name);
3649 ppad = AvARRAY(pad);
3651 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
3652 if (SvPOK(pname[ix]))
3653 PerlIO_printf(Perl_debug_log, "\t%4d. 0x%lx (%s\"%s\" %ld-%ld)\n",
3655 SvFAKE(pname[ix]) ? "FAKE " : "",
3657 (long)I_32(SvNVX(pname[ix])),
3658 (long)SvIVX(pname[ix]));
3661 #endif /* DEBUG_CLOSURES */
3664 cv_clone2(CV *proto, CV *outside)
3669 AV* protopadlist = CvPADLIST(proto);
3670 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
3671 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
3672 SV** pname = AvARRAY(protopad_name);
3673 SV** ppad = AvARRAY(protopad);
3674 I32 fname = AvFILLp(protopad_name);
3675 I32 fpad = AvFILLp(protopad);
3679 assert(!CvUNIQUE(proto));
3682 SAVESPTR(PL_curpad);
3683 SAVESPTR(PL_comppad);
3684 SAVESPTR(PL_comppad_name);
3685 SAVESPTR(PL_compcv);
3687 cv = PL_compcv = (CV*)NEWSV(1104,0);
3688 sv_upgrade((SV *)cv, SvTYPE(proto));
3694 New(666, CvMUTEXP(cv), 1, perl_mutex);
3695 MUTEX_INIT(CvMUTEXP(cv));
3697 #endif /* USE_THREADS */
3698 CvFILEGV(cv) = CvFILEGV(proto);
3699 CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
3700 CvSTASH(cv) = CvSTASH(proto);
3701 CvROOT(cv) = CvROOT(proto);
3702 CvSTART(cv) = CvSTART(proto);
3704 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
3707 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
3709 PL_comppad_name = newAV();
3710 for (ix = fname; ix >= 0; ix--)
3711 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
3713 PL_comppad = newAV();
3715 comppadlist = newAV();
3716 AvREAL_off(comppadlist);
3717 av_store(comppadlist, 0, (SV*)PL_comppad_name);
3718 av_store(comppadlist, 1, (SV*)PL_comppad);
3719 CvPADLIST(cv) = comppadlist;
3720 av_fill(PL_comppad, AvFILLp(protopad));
3721 PL_curpad = AvARRAY(PL_comppad);
3723 av = newAV(); /* will be @_ */
3725 av_store(PL_comppad, 0, (SV*)av);
3726 AvFLAGS(av) = AVf_REIFY;
3728 for (ix = fpad; ix > 0; ix--) {
3729 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
3730 if (namesv && namesv != &PL_sv_undef) {
3731 char *name = SvPVX(namesv); /* XXX */
3732 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
3733 I32 off = pad_findlex(name, ix, SvIVX(namesv),
3734 CvOUTSIDE(cv), cxstack_ix, 0, 0);
3736 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
3738 croak("panic: cv_clone: %s", name);
3740 else { /* our own lexical */
3743 /* anon code -- we'll come back for it */
3744 sv = SvREFCNT_inc(ppad[ix]);
3746 else if (*name == '@')
3748 else if (*name == '%')
3758 SV* sv = NEWSV(0,0);
3764 /* Now that vars are all in place, clone nested closures. */
3766 for (ix = fpad; ix > 0; ix--) {
3767 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
3769 && namesv != &PL_sv_undef
3770 && !(SvFLAGS(namesv) & SVf_FAKE)
3771 && *SvPVX(namesv) == '&'
3772 && CvCLONE(ppad[ix]))
3774 CV *kid = cv_clone2((CV*)ppad[ix], cv);
3775 SvREFCNT_dec(ppad[ix]);
3778 PL_curpad[ix] = (SV*)kid;
3782 #ifdef DEBUG_CLOSURES
3783 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
3785 PerlIO_printf(Perl_debug_log, " from:\n");
3787 PerlIO_printf(Perl_debug_log, " to:\n");
3799 MUTEX_LOCK(&PL_cred_mutex); /* XXX create separate mutex */
3800 cv = cv_clone2(proto, CvOUTSIDE(proto));
3801 MUTEX_UNLOCK(&PL_cred_mutex); /* XXX create separate mutex */
3806 cv_ckproto(CV *cv, GV *gv, char *p)
3808 if ((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) {
3809 SV* msg = sv_newmortal();
3813 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3814 sv_setpv(msg, "Prototype mismatch:");
3816 sv_catpvf(msg, " sub %_", name);
3818 sv_catpvf(msg, " (%s)", SvPVX(cv));
3819 sv_catpv(msg, " vs ");
3821 sv_catpvf(msg, "(%s)", p);
3823 sv_catpv(msg, "none");
3831 if (!cv || !SvPOK(cv) || SvCUR(cv))
3833 return op_const_sv(CvSTART(cv), cv);
3837 op_const_sv(OP *o, CV *cv)
3844 if(o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3845 o = cLISTOPo->op_first->op_sibling;
3847 for (; o; o = o->op_next) {
3848 OPCODE type = o->op_type;
3850 if(sv && o->op_next == o)
3852 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3854 if (type == OP_LEAVESUB || type == OP_RETURN)
3858 if (type == OP_CONST)
3860 else if (type == OP_PADSV && cv) {
3861 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
3862 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
3863 if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1))
3875 newSUB(I32 floor, OP *o, OP *proto, OP *block)
3879 char *name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3880 GV *gv = gv_fetchpv(name ? name : "__ANON__",
3881 GV_ADDMULTI | (block ? 0 : GV_NOINIT), SVt_PVCV);
3882 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3891 if (SvTYPE(gv) != SVt_PVGV) { /* Prototype now, and had
3892 maximum a prototype before. */
3893 if (SvTYPE(gv) > SVt_NULL) {
3894 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1))
3895 warn("Runaway prototype");
3896 cv_ckproto((CV*)gv, NULL, ps);
3899 sv_setpv((SV*)gv, ps);
3901 sv_setiv((SV*)gv, -1);
3902 SvREFCNT_dec(PL_compcv);
3903 cv = PL_compcv = NULL;
3904 PL_sub_generation++;
3908 if (!name || GvCVGEN(gv))
3910 else if (cv = GvCV(gv)) {
3911 cv_ckproto(cv, gv, ps);
3912 /* already defined (or promised)? */
3913 if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
3915 bool const_changed = TRUE;
3917 /* just a "sub foo;" when &foo is already defined */
3918 SAVEFREESV(PL_compcv);
3921 /* ahem, death to those who redefine active sort subs */
3922 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
3923 croak("Can't redefine active sort subroutine %s", name);
3924 if(const_sv = cv_const_sv(cv))
3925 const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
3926 if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE)
3927 && !(CvGV(cv) && GvSTASH(CvGV(cv))
3928 && HvNAME(GvSTASH(CvGV(cv)))
3929 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
3931 line_t oldline = PL_curcop->cop_line;
3932 PL_curcop->cop_line = PL_copline;
3933 warner(WARN_REDEFINE,
3934 const_sv ? "Constant subroutine %s redefined"
3935 : "Subroutine %s redefined", name);
3936 PL_curcop->cop_line = oldline;
3942 if (cv) { /* must reuse cv if autoloaded */
3944 CvFLAGS(cv) = CvFLAGS(PL_compcv);
3945 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
3946 CvOUTSIDE(PL_compcv) = 0;
3947 CvPADLIST(cv) = CvPADLIST(PL_compcv);
3948 CvPADLIST(PL_compcv) = 0;
3949 if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
3950 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
3951 SvREFCNT_dec(PL_compcv);
3958 PL_sub_generation++;
3961 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
3962 CvFILEGV(cv) = PL_curcop->cop_filegv;
3963 CvSTASH(cv) = PL_curstash;
3966 if (!CvMUTEXP(cv)) {
3967 New(666, CvMUTEXP(cv), 1, perl_mutex);
3968 MUTEX_INIT(CvMUTEXP(cv));
3970 #endif /* USE_THREADS */
3973 sv_setpv((SV*)cv, ps);
3975 if (PL_error_count) {
3979 char *s = strrchr(name, ':');
3981 if (strEQ(s, "BEGIN")) {
3983 "BEGIN not safe after errors--compilation aborted";
3987 /* force display of errors found but not reported */
3988 sv_catpv(ERRSV, not_safe);
3989 croak("%s", SvPVx(ERRSV, n_a));
3996 PL_copline = NOLINE;
4001 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4002 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4005 SV **namep = AvARRAY(PL_comppad_name);
4006 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4009 if (SvIMMORTAL(PL_curpad[ix]))
4012 * The only things that a clonable function needs in its
4013 * pad are references to outer lexicals and anonymous subs.
4014 * The rest are created anew during cloning.
4016 if (!((namesv = namep[ix]) != Nullsv &&
4017 namesv != &PL_sv_undef &&
4019 *SvPVX(namesv) == '&')))
4021 SvREFCNT_dec(PL_curpad[ix]);
4022 PL_curpad[ix] = Nullsv;
4027 AV *av = newAV(); /* Will be @_ */
4029 av_store(PL_comppad, 0, (SV*)av);
4030 AvFLAGS(av) = AVf_REIFY;
4032 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4033 if (SvIMMORTAL(PL_curpad[ix]))
4035 if (!SvPADMY(PL_curpad[ix]))
4036 SvPADTMP_on(PL_curpad[ix]);
4040 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4041 CvSTART(cv) = LINKLIST(CvROOT(cv));
4042 CvROOT(cv)->op_next = 0;
4048 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4049 SV *sv = NEWSV(0,0);
4050 SV *tmpstr = sv_newmortal();
4051 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4055 sv_setpvf(sv, "%_:%ld-%ld",
4056 GvSV(PL_curcop->cop_filegv),
4057 (long)PL_subline, (long)PL_curcop->cop_line);
4058 gv_efullname3(tmpstr, gv, Nullch);
4059 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4060 hv = GvHVn(db_postponed);
4061 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4062 && (cv = GvCV(db_postponed))) {
4067 perl_call_sv((SV*)cv, G_DISCARD);
4071 if ((s = strrchr(name,':')))
4075 if (strEQ(s, "BEGIN")) {
4076 I32 oldscope = PL_scopestack_ix;
4078 SAVESPTR(PL_compiling.cop_filegv);
4079 SAVEI16(PL_compiling.cop_line);
4081 sv_setsv(PL_rs, PL_nrs);
4084 PL_beginav = newAV();
4085 DEBUG_x( dump_sub(gv) );
4086 av_push(PL_beginav, (SV *)cv);
4088 call_list(oldscope, PL_beginav);
4090 PL_curcop = &PL_compiling;
4091 PL_compiling.op_private = PL_hints;
4094 else if (strEQ(s, "END") && !PL_error_count) {
4097 av_unshift(PL_endav, 1);
4098 av_store(PL_endav, 0, (SV *)cv);
4101 else if (strEQ(s, "INIT") && !PL_error_count) {
4103 PL_initav = newAV();
4104 av_push(PL_initav, SvREFCNT_inc(cv));
4110 PL_copline = NOLINE;
4115 /* XXX unsafe for threads if eval_owner isn't held */
4117 newCONSTSUB(HV *stash, char *name, SV *sv)
4120 U32 oldhints = PL_hints;
4121 HV *old_cop_stash = PL_curcop->cop_stash;
4122 HV *old_curstash = PL_curstash;
4123 line_t oldline = PL_curcop->cop_line;
4124 PL_curcop->cop_line = PL_copline;
4126 PL_hints &= ~HINT_BLOCK_SCOPE;
4128 PL_curstash = PL_curcop->cop_stash = stash;
4131 start_subparse(FALSE, 0),
4132 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4133 newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
4134 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
4137 PL_hints = oldhints;
4138 PL_curcop->cop_stash = old_cop_stash;
4139 PL_curstash = old_curstash;
4140 PL_curcop->cop_line = oldline;
4144 newXS(char *name, void (*subaddr) (CV * _CPERLproto), char *filename)
4147 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4150 if (cv = (name ? GvCV(gv) : Nullcv)) {
4152 /* just a cached method */
4156 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4157 /* already defined (or promised) */
4158 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4159 && HvNAME(GvSTASH(CvGV(cv)))
4160 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4161 line_t oldline = PL_curcop->cop_line;
4162 if (PL_copline != NOLINE)
4163 PL_curcop->cop_line = PL_copline;
4164 warner(WARN_REDEFINE, "Subroutine %s redefined",name);
4165 PL_curcop->cop_line = oldline;
4172 if (cv) /* must reuse cv if autoloaded */
4175 cv = (CV*)NEWSV(1105,0);
4176 sv_upgrade((SV *)cv, SVt_PVCV);
4180 PL_sub_generation++;
4183 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4185 New(666, CvMUTEXP(cv), 1, perl_mutex);
4186 MUTEX_INIT(CvMUTEXP(cv));
4188 #endif /* USE_THREADS */
4189 CvFILEGV(cv) = gv_fetchfile(filename);
4190 CvXSUB(cv) = subaddr;
4193 char *s = strrchr(name,':');
4198 if (strEQ(s, "BEGIN")) {
4200 PL_beginav = newAV();
4201 av_push(PL_beginav, (SV *)cv);
4204 else if (strEQ(s, "END")) {
4207 av_unshift(PL_endav, 1);
4208 av_store(PL_endav, 0, (SV *)cv);
4211 else if (strEQ(s, "INIT")) {
4213 PL_initav = newAV();
4214 av_push(PL_initav, (SV *)cv);
4225 newFORM(I32 floor, OP *o, OP *block)
4235 name = SvPVx(cSVOPo->op_sv, n_a);
4238 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4240 if (cv = GvFORM(gv)) {
4241 if (ckWARN(WARN_REDEFINE)) {
4242 line_t oldline = PL_curcop->cop_line;
4244 PL_curcop->cop_line = PL_copline;
4245 warner(WARN_REDEFINE, "Format %s redefined",name);
4246 PL_curcop->cop_line = oldline;
4252 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4253 CvFILEGV(cv) = PL_curcop->cop_filegv;
4255 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4256 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
4257 SvPADTMP_on(PL_curpad[ix]);
4260 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4261 CvSTART(cv) = LINKLIST(CvROOT(cv));
4262 CvROOT(cv)->op_next = 0;
4265 PL_copline = NOLINE;
4272 return newUNOP(OP_REFGEN, 0,
4273 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4279 return newUNOP(OP_REFGEN, 0,
4280 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4284 newANONSUB(I32 floor, OP *proto, OP *block)
4286 return newUNOP(OP_REFGEN, 0,
4287 newSVOP(OP_ANONCODE, 0, (SV*)newSUB(floor, 0, proto, block)));
4293 switch (o->op_type) {
4295 o->op_type = OP_PADAV;
4296 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4297 return ref(o, OP_RV2AV);
4300 o->op_type = OP_RV2AV;
4301 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4306 warn("oops: oopsAV");
4315 switch (o->op_type) {
4318 o->op_type = OP_PADHV;
4319 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4320 return ref(o, OP_RV2HV);
4324 o->op_type = OP_RV2HV;
4325 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4330 warn("oops: oopsHV");
4339 if (o->op_type == OP_PADANY) {
4340 o->op_type = OP_PADAV;
4341 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4344 return newUNOP(OP_RV2AV, 0, scalar(o));
4348 newGVREF(I32 type, OP *o)
4350 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4351 return newUNOP(OP_NULL, 0, o);
4352 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4358 if (o->op_type == OP_PADANY) {
4359 o->op_type = OP_PADHV;
4360 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4363 return newUNOP(OP_RV2HV, 0, scalar(o));
4369 croak("NOT IMPL LINE %d",__LINE__);
4375 newCVREF(I32 flags, OP *o)
4377 return newUNOP(OP_RV2CV, flags, scalar(o));
4383 if (o->op_type == OP_PADANY) {
4384 o->op_type = OP_PADSV;
4385 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4388 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4389 o->op_flags |= OPpDONE_SVREF;
4392 return newUNOP(OP_RV2SV, 0, scalar(o));
4395 /* Check routines. */
4403 name = NEWSV(1106,0);
4404 sv_upgrade(name, SVt_PVNV);
4405 sv_setpvn(name, "&", 1);
4408 ix = pad_alloc(o->op_type, SVs_PADMY);
4409 av_store(PL_comppad_name, ix, name);
4410 av_store(PL_comppad, ix, cSVOPo->op_sv);
4411 SvPADMY_on(cSVOPo->op_sv);
4412 cSVOPo->op_sv = Nullsv;
4413 cSVOPo->op_targ = ix;
4420 o->op_private = PL_hints;
4427 if (cUNOPo->op_first->op_type == OP_CONCAT)
4428 o->op_flags |= OPf_STACKED;
4435 if (o->op_flags & OPf_KIDS) {
4438 OPCODE type = o->op_type;
4439 o = modkids(ck_fun(o), type);
4440 kid = cUNOPo->op_first;
4441 newop = kUNOP->op_first->op_sibling;
4443 (newop->op_sibling ||
4444 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4445 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4446 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4450 op_free(kUNOP->op_first);
4451 kUNOP->op_first = newop;
4453 o->op_ppaddr = PL_ppaddr[++o->op_type];
4462 if (o->op_flags & OPf_KIDS) {
4463 OP *kid = cUNOPo->op_first;
4464 if (kid->op_type == OP_HSLICE)
4465 o->op_private |= OPpSLICE;
4466 else if (kid->op_type != OP_HELEM)
4467 croak("%s argument is not a HASH element or slice",
4468 PL_op_desc[o->op_type]);
4477 I32 type = o->op_type;
4479 if (o->op_flags & OPf_KIDS) {
4480 if (cLISTOPo->op_first->op_type == OP_STUB) {
4482 o = newUNOP(type, OPf_SPECIAL,
4483 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
4493 PL_hints |= HINT_BLOCK_SCOPE;
4494 if (o->op_flags & OPf_KIDS) {
4495 SVOP *kid = (SVOP*)cUNOPo->op_first;
4498 o->op_flags &= ~OPf_KIDS;
4501 else if (kid->op_type == OP_LINESEQ) {
4504 kid->op_next = o->op_next;
4505 cUNOPo->op_first = 0;
4508 NewOp(1101, enter, 1, LOGOP);
4509 enter->op_type = OP_ENTERTRY;
4510 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4511 enter->op_private = 0;
4513 /* establish postfix order */
4514 enter->op_next = (OP*)enter;
4516 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4517 o->op_type = OP_LEAVETRY;
4518 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4519 enter->op_other = o;
4527 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4529 o->op_targ = (PADOFFSET)PL_hints;
4537 if (o->op_flags & OPf_STACKED) {
4539 kid = cUNOPo->op_first->op_sibling;
4540 if (kid->op_type == OP_RV2GV)
4552 if (o->op_flags & OPf_KIDS) {
4553 OP *kid = cUNOPo->op_first;
4554 if (kid->op_type != OP_HELEM)
4555 croak("%s argument is not a HASH element", PL_op_desc[o->op_type]);
4563 ck_gvconst(register OP *o)
4565 o = fold_constants(o);
4566 if (o->op_type == OP_CONST)
4573 ck_rvconst(register OP *o)
4576 SVOP *kid = (SVOP*)cUNOPo->op_first;
4578 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4579 if (kid->op_type == OP_CONST) {
4583 SV *kidsv = kid->op_sv;
4586 /* Is it a constant from cv_const_sv()? */
4587 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4588 SV *rsv = SvRV(kidsv);
4589 int svtype = SvTYPE(rsv);
4590 char *badtype = Nullch;
4592 switch (o->op_type) {
4594 if (svtype > SVt_PVMG)
4595 badtype = "a SCALAR";
4598 if (svtype != SVt_PVAV)
4599 badtype = "an ARRAY";
4602 if (svtype != SVt_PVHV) {
4603 if (svtype == SVt_PVAV) { /* pseudohash? */
4604 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
4605 if (ksv && SvROK(*ksv)
4606 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
4615 if (svtype != SVt_PVCV)
4620 croak("Constant is not %s reference", badtype);
4623 name = SvPV(kidsv, n_a);
4624 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4625 char *badthing = Nullch;
4626 switch (o->op_type) {
4628 badthing = "a SCALAR";
4631 badthing = "an ARRAY";
4634 badthing = "a HASH";
4639 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4643 * This is a little tricky. We only want to add the symbol if we
4644 * didn't add it in the lexer. Otherwise we get duplicate strict
4645 * warnings. But if we didn't add it in the lexer, we must at
4646 * least pretend like we wanted to add it even if it existed before,
4647 * or we get possible typo warnings. OPpCONST_ENTERED says
4648 * whether the lexer already added THIS instance of this symbol.
4650 iscv = (o->op_type == OP_RV2CV) * 2;
4652 gv = gv_fetchpv(name,
4653 iscv | !(kid->op_private & OPpCONST_ENTERED),
4656 : o->op_type == OP_RV2SV
4658 : o->op_type == OP_RV2AV
4660 : o->op_type == OP_RV2HV
4663 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4665 kid->op_type = OP_GV;
4666 SvREFCNT_dec(kid->op_sv);
4667 kid->op_sv = SvREFCNT_inc(gv);
4677 I32 type = o->op_type;
4679 if (o->op_flags & OPf_REF)
4682 if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4683 SVOP *kid = (SVOP*)cUNOPo->op_first;
4685 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4687 OP *newop = newGVOP(type, OPf_REF,
4688 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4695 if (type == OP_FTTTY)
4696 return newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
4699 return newUNOP(type, 0, newDEFSVOP());
4712 int type = o->op_type;
4713 register I32 oa = PL_opargs[type] >> OASHIFT;
4715 if (o->op_flags & OPf_STACKED) {
4716 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4719 return no_fh_allowed(o);
4722 if (o->op_flags & OPf_KIDS) {
4724 tokid = &cLISTOPo->op_first;
4725 kid = cLISTOPo->op_first;
4726 if (kid->op_type == OP_PUSHMARK ||
4727 kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)
4729 tokid = &kid->op_sibling;
4730 kid = kid->op_sibling;
4732 if (!kid && PL_opargs[type] & OA_DEFGV)
4733 *tokid = kid = newDEFSVOP();
4737 sibl = kid->op_sibling;
4740 /* list seen where single (scalar) arg expected? */
4741 if (numargs == 1 && !(oa >> 4)
4742 && kid->op_type == OP_LIST && type != OP_SCALAR)
4744 return too_many_arguments(o,PL_op_desc[type]);
4757 if (kid->op_type == OP_CONST &&
4758 (kid->op_private & OPpCONST_BARE))
4760 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
4761 OP *newop = newAVREF(newGVOP(OP_GV, 0,
4762 gv_fetchpv(name, TRUE, SVt_PVAV) ));
4763 if (ckWARN(WARN_SYNTAX))
4765 "Array @%s missing the @ in argument %ld of %s()",
4766 name, (long)numargs, PL_op_desc[type]);
4769 kid->op_sibling = sibl;
4772 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
4773 bad_type(numargs, "array", PL_op_desc[type], kid);
4777 if (kid->op_type == OP_CONST &&
4778 (kid->op_private & OPpCONST_BARE))
4780 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
4781 OP *newop = newHVREF(newGVOP(OP_GV, 0,
4782 gv_fetchpv(name, TRUE, SVt_PVHV) ));
4783 if (ckWARN(WARN_SYNTAX))
4785 "Hash %%%s missing the %% in argument %ld of %s()",
4786 name, (long)numargs, PL_op_desc[type]);
4789 kid->op_sibling = sibl;
4792 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
4793 bad_type(numargs, "hash", PL_op_desc[type], kid);
4798 OP *newop = newUNOP(OP_NULL, 0, kid);
4799 kid->op_sibling = 0;
4801 newop->op_next = newop;
4803 kid->op_sibling = sibl;
4808 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
4809 if (kid->op_type == OP_CONST &&
4810 (kid->op_private & OPpCONST_BARE))
4812 OP *newop = newGVOP(OP_GV, 0,
4813 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
4818 else if (kid->op_type == OP_READLINE) {
4819 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
4820 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
4823 I32 flags = OPf_SPECIAL;
4825 /* is this op a FH constructor? */
4826 if (is_handle_constructor(o,numargs)) {
4828 /* Set a flag to tell rv2gv to vivify
4829 * need to "prove" flag does not mean something
4830 * else already - NI-S 1999/05/07
4834 /* Helps with open($array[$n],...)
4835 but is too simplistic - need to do selectively
4840 kid->op_sibling = 0;
4841 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
4843 kid->op_private |= priv;
4846 kid->op_sibling = sibl;
4852 mod(scalar(kid), type);
4856 tokid = &kid->op_sibling;
4857 kid = kid->op_sibling;
4859 o->op_private |= numargs;
4861 return too_many_arguments(o,PL_op_desc[o->op_type]);
4864 else if (PL_opargs[type] & OA_DEFGV) {
4866 return newUNOP(type, 0, newDEFSVOP());
4870 while (oa & OA_OPTIONAL)
4872 if (oa && oa != OA_LIST)
4873 return too_few_arguments(o,PL_op_desc[o->op_type]);
4883 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
4884 append_elem(OP_GLOB, o, newDEFSVOP());
4886 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
4887 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
4889 if (gv && GvIMPORTED_CV(gv)) {
4890 append_elem(OP_GLOB, o,
4891 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
4892 o->op_type = OP_LIST;
4893 o->op_ppaddr = PL_ppaddr[OP_LIST];
4894 cLISTOPo->op_first->op_type = OP_PUSHMARK;
4895 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
4896 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
4897 append_elem(OP_LIST, o,
4898 scalar(newUNOP(OP_RV2CV, 0,
4899 newGVOP(OP_GV, 0, gv)))));
4900 o = newUNOP(OP_NULL, 0, ck_subr(o));
4901 o->op_targ = OP_GLOB; /* hint at what it used to be */
4904 gv = newGVgen("main");
4906 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
4916 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
4918 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
4919 NewOp(1101, gwop, 1, LOGOP);
4921 if (o->op_flags & OPf_STACKED) {
4924 kid = cLISTOPo->op_first->op_sibling;
4925 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
4928 kid->op_next = (OP*)gwop;
4929 o->op_flags &= ~OPf_STACKED;
4931 kid = cLISTOPo->op_first->op_sibling;
4932 if (type == OP_MAPWHILE)
4939 kid = cLISTOPo->op_first->op_sibling;
4940 if (kid->op_type != OP_NULL)
4941 croak("panic: ck_grep");
4942 kid = kUNOP->op_first;
4944 gwop->op_type = type;
4945 gwop->op_ppaddr = PL_ppaddr[type];
4946 gwop->op_first = listkids(o);
4947 gwop->op_flags |= OPf_KIDS;
4948 gwop->op_private = 1;
4949 gwop->op_other = LINKLIST(kid);
4950 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
4951 kid->op_next = (OP*)gwop;
4953 kid = cLISTOPo->op_first->op_sibling;
4954 if (!kid || !kid->op_sibling)
4955 return too_few_arguments(o,PL_op_desc[o->op_type]);
4956 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
4957 mod(kid, OP_GREPSTART);
4965 if (o->op_flags & OPf_KIDS) {
4966 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
4968 kid = kid->op_sibling; /* get past "big" */
4969 if (kid && kid->op_type == OP_CONST)
4970 fbm_compile(((SVOP*)kid)->op_sv, 0);
4976 ck_lengthconst(OP *o)
4978 /* XXX length optimization goes here */
4985 OPCODE type = o->op_type;
4986 return modkids(ck_fun(o), type);
4992 OPCODE type = o->op_type;
4993 return refkids(ck_fun(o), type);
5001 kid = cLISTOPo->op_first;
5004 kid = cLISTOPo->op_first;
5006 if (kid->op_type == OP_PUSHMARK)
5007 kid = kid->op_sibling;
5008 if (kid && o->op_flags & OPf_STACKED)
5009 kid = kid->op_sibling;
5010 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5011 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5012 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5013 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5014 cLISTOPo->op_first->op_sibling = kid;
5015 cLISTOPo->op_last = kid;
5016 kid = kid->op_sibling;
5021 append_elem(o->op_type, o, newDEFSVOP());
5027 if (PL_hints & HINT_LOCALE)
5028 o->op_private |= OPpLOCALE;
5035 ck_fun_locale(OP *o)
5041 if (PL_hints & HINT_LOCALE)
5042 o->op_private |= OPpLOCALE;
5053 if (PL_hints & HINT_LOCALE)
5054 o->op_private |= OPpLOCALE;
5063 o->op_private |= OPpRUNTIME;
5076 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5077 o->op_private |= OPpREPEAT_DOLIST;
5078 cBINOPo->op_first = force_list(cBINOPo->op_first);
5088 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5089 SVOP *kid = (SVOP*)cUNOPo->op_first;
5091 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5093 for (s = SvPVX(kid->op_sv); *s; s++) {
5094 if (*s == ':' && s[1] == ':') {
5096 Move(s+2, s+1, strlen(s+2)+1, char);
5097 --SvCUR(kid->op_sv);
5100 sv_catpvn(kid->op_sv, ".pm", 3);
5110 croak("NOT IMPL LINE %d",__LINE__);
5120 if (o->op_flags & OPf_KIDS) {
5121 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5122 if (kid && kid->op_sibling) {
5123 o->op_type = OP_SSELECT;
5124 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5126 return fold_constants(o);
5130 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5131 if (kid && kid->op_type == OP_RV2GV)
5132 kid->op_private &= ~HINT_STRICT_REFS;
5139 I32 type = o->op_type;
5141 if (!(o->op_flags & OPf_KIDS)) {
5146 if (!CvUNIQUE(PL_compcv)) {
5147 argop = newOP(OP_PADAV, OPf_REF);
5148 argop->op_targ = 0; /* PL_curpad[0] is @_ */
5151 argop = newUNOP(OP_RV2AV, 0,
5152 scalar(newGVOP(OP_GV, 0,
5153 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5156 argop = newUNOP(OP_RV2AV, 0,
5157 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
5158 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5159 #endif /* USE_THREADS */
5160 return newUNOP(type, 0, scalar(argop));
5162 return scalar(modkids(ck_fun(o), type));
5170 if (PL_hints & HINT_LOCALE)
5171 o->op_private |= OPpLOCALE;
5174 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5176 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5177 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5179 kid = kUNOP->op_first; /* get past null */
5181 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5183 if (kid->op_type == OP_SCOPE) {
5187 else if (kid->op_type == OP_LEAVE) {
5188 if (o->op_type == OP_SORT) {
5189 null(kid); /* wipe out leave */
5192 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5193 if (k->op_next == kid)
5198 kid->op_next = 0; /* just disconnect the leave */
5199 k = kLISTOP->op_first;
5203 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5204 if (o->op_type == OP_SORT)
5208 o->op_flags |= OPf_SPECIAL;
5210 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5211 null(cLISTOPo->op_first->op_sibling);
5218 simplify_sort(OP *o)
5221 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5224 if (!(o->op_flags & OPf_STACKED))
5226 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5227 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5228 kid = kUNOP->op_first; /* get past null */
5229 if (kid->op_type != OP_SCOPE)
5231 kid = kLISTOP->op_last; /* get past scope */
5232 switch(kid->op_type) {
5240 k = kid; /* remember this node*/
5241 if (kBINOP->op_first->op_type != OP_RV2SV)
5243 kid = kBINOP->op_first; /* get past cmp */
5244 if (kUNOP->op_first->op_type != OP_GV)
5246 kid = kUNOP->op_first; /* get past rv2sv */
5247 if (GvSTASH(kGVOP->op_gv) != PL_curstash)
5249 if (strEQ(GvNAME(kGVOP->op_gv), "a"))
5251 else if(strEQ(GvNAME(kGVOP->op_gv), "b"))
5255 kid = k; /* back to cmp */
5256 if (kBINOP->op_last->op_type != OP_RV2SV)
5258 kid = kBINOP->op_last; /* down to 2nd arg */
5259 if (kUNOP->op_first->op_type != OP_GV)
5261 kid = kUNOP->op_first; /* get past rv2sv */
5262 if (GvSTASH(kGVOP->op_gv) != PL_curstash
5264 ? strNE(GvNAME(kGVOP->op_gv), "a")
5265 : strNE(GvNAME(kGVOP->op_gv), "b")))
5267 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5269 o->op_private |= OPpSORT_REVERSE;
5270 if (k->op_type == OP_NCMP)
5271 o->op_private |= OPpSORT_NUMERIC;
5272 if (k->op_type == OP_I_NCMP)
5273 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5274 op_free(cLISTOPo->op_first->op_sibling); /* delete comparison block */
5275 cLISTOPo->op_first->op_sibling = cLISTOPo->op_last;
5276 cLISTOPo->op_children = 1;
5284 if (o->op_flags & OPf_STACKED)
5285 return no_fh_allowed(o);
5287 kid = cLISTOPo->op_first;
5288 if (kid->op_type != OP_NULL)
5289 croak("panic: ck_split");
5290 kid = kid->op_sibling;
5291 op_free(cLISTOPo->op_first);
5292 cLISTOPo->op_first = kid;
5294 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5295 cLISTOPo->op_last = kid; /* There was only one element previously */
5298 if (kid->op_type != OP_MATCH) {
5299 OP *sibl = kid->op_sibling;
5300 kid->op_sibling = 0;
5301 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5302 if (cLISTOPo->op_first == cLISTOPo->op_last)
5303 cLISTOPo->op_last = kid;
5304 cLISTOPo->op_first = kid;
5305 kid->op_sibling = sibl;
5308 kid->op_type = OP_PUSHRE;
5309 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5312 if (!kid->op_sibling)
5313 append_elem(OP_SPLIT, o, newDEFSVOP());
5315 kid = kid->op_sibling;
5318 if (!kid->op_sibling)
5319 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5321 kid = kid->op_sibling;
5324 if (kid->op_sibling)
5325 return too_many_arguments(o,PL_op_desc[o->op_type]);
5334 OP *prev = ((cUNOPo->op_first->op_sibling)
5335 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5336 OP *o2 = prev->op_sibling;
5345 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5346 if (cvop->op_type == OP_RV2CV) {
5348 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5349 null(cvop); /* disable rv2cv */
5350 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5351 if (tmpop->op_type == OP_GV) {
5352 cv = GvCVu(tmpop->op_sv);
5353 if (cv && SvPOK(cv) && !(o->op_private & OPpENTERSUB_AMPER)) {
5354 namegv = CvANON(cv) ? (GV*)tmpop->op_sv : CvGV(cv);
5355 proto = SvPV((SV*)cv, n_a);
5359 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5360 if (PERLDB_SUB && PL_curstash != PL_debstash)
5361 o->op_private |= OPpENTERSUB_DB;
5362 while (o2 != cvop) {
5366 return too_many_arguments(o, gv_ename(namegv));
5384 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5385 bad_type(arg, "block", gv_ename(namegv), o2);
5388 /* '*' allows any scalar type, including bareword */
5391 if (o2->op_type == OP_RV2GV)
5392 goto wrapref; /* autoconvert GLOB -> GLOBref */
5400 if (o2->op_type != OP_RV2GV)
5401 bad_type(arg, "symbol", gv_ename(namegv), o2);
5404 if (o2->op_type != OP_RV2CV)
5405 bad_type(arg, "sub", gv_ename(namegv), o2);
5408 if (o2->op_type != OP_RV2SV
5409 && o2->op_type != OP_PADSV
5410 && o2->op_type != OP_THREADSV)
5412 bad_type(arg, "scalar", gv_ename(namegv), o2);
5416 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
5417 bad_type(arg, "array", gv_ename(namegv), o2);
5420 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
5421 bad_type(arg, "hash", gv_ename(namegv), o2);
5425 OP* sib = kid->op_sibling;
5426 kid->op_sibling = 0;
5427 o2 = newUNOP(OP_REFGEN, 0, kid);
5428 o2->op_sibling = sib;
5429 prev->op_sibling = o2;
5440 croak("Malformed prototype for %s: %s",
5441 gv_ename(namegv), SvPV((SV*)cv, n_a));
5446 mod(o2, OP_ENTERSUB);
5448 o2 = o2->op_sibling;
5450 if (proto && !optional &&
5451 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5452 return too_few_arguments(o, gv_ename(namegv));
5459 SvREADONLY_on(cSVOPo->op_sv);
5466 if (o->op_flags & OPf_KIDS) {
5467 SVOP *kid = (SVOP*)cUNOPo->op_first;
5469 if (kid->op_type == OP_NULL)
5470 kid = (SVOP*)kid->op_sibling;
5472 kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE))
5473 o->op_flags |= OPf_SPECIAL;
5478 /* A peephole optimizer. We visit the ops in the order they're to execute. */
5481 peep(register OP *o)
5484 register OP* oldop = 0;
5487 if (!o || o->op_seq)
5491 SAVESPTR(PL_curcop);
5492 for (; o; o = o->op_next) {
5498 switch (o->op_type) {
5501 PL_curcop = ((COP*)o); /* for warnings */
5502 o->op_seq = PL_op_seqmax++;
5513 if (o->op_next && o->op_next->op_type == OP_STRINGIFY)
5515 o->op_seq = PL_op_seqmax++;
5518 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
5519 o->op_seq = PL_op_seqmax++;
5520 break; /* Scalar stub must produce undef. List stub is noop */
5524 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
5525 PL_curcop = ((COP*)o);
5531 if (oldop && o->op_next) {
5532 oldop->op_next = o->op_next;
5535 o->op_seq = PL_op_seqmax++;
5539 if (o->op_next->op_type == OP_RV2SV) {
5540 if (!(o->op_next->op_private & OPpDEREF)) {
5542 o->op_private |= o->op_next->op_private & OPpLVAL_INTRO;
5543 o->op_next = o->op_next->op_next;
5544 o->op_type = OP_GVSV;
5545 o->op_ppaddr = PL_ppaddr[OP_GVSV];
5548 else if (o->op_next->op_type == OP_RV2AV) {
5549 OP* pop = o->op_next->op_next;
5551 if (pop->op_type == OP_CONST &&
5552 (PL_op = pop->op_next) &&
5553 pop->op_next->op_type == OP_AELEM &&
5554 !(pop->op_next->op_private &
5555 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) &&
5556 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
5560 SvREFCNT_dec(((SVOP*)pop)->op_sv);
5564 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
5565 o->op_next = pop->op_next->op_next;
5566 o->op_type = OP_AELEMFAST;
5567 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
5568 o->op_private = (U8)i;
5569 GvAVn(((GVOP*)o)->op_gv);
5572 o->op_seq = PL_op_seqmax++;
5579 o->op_seq = PL_op_seqmax++;
5580 while (cLOGOP->op_other->op_type == OP_NULL)
5581 cLOGOP->op_other = cLOGOP->op_other->op_next;
5582 peep(cLOGOP->op_other);
5586 o->op_seq = PL_op_seqmax++;
5587 peep(cCONDOP->op_true);
5588 peep(cCONDOP->op_false);
5592 o->op_seq = PL_op_seqmax++;
5593 peep(cLOOP->op_redoop);
5594 peep(cLOOP->op_nextop);
5595 peep(cLOOP->op_lastop);
5601 o->op_seq = PL_op_seqmax++;
5602 peep(cPMOP->op_pmreplstart);
5606 o->op_seq = PL_op_seqmax++;
5607 if (ckWARN(WARN_SYNTAX) && o->op_next
5608 && o->op_next->op_type == OP_NEXTSTATE) {
5609 if (o->op_next->op_sibling &&
5610 o->op_next->op_sibling->op_type != OP_EXIT &&
5611 o->op_next->op_sibling->op_type != OP_WARN &&
5612 o->op_next->op_sibling->op_type != OP_DIE) {
5613 line_t oldline = PL_curcop->cop_line;
5615 PL_curcop->cop_line = ((COP*)o->op_next)->cop_line;
5616 warner(WARN_SYNTAX, "Statement unlikely to be reached");
5617 warner(WARN_SYNTAX, "(Maybe you meant system() when you said exec()?)\n");
5618 PL_curcop->cop_line = oldline;
5632 if ((o->op_private & (OPpLVAL_INTRO))
5633 || ((BINOP*)o)->op_last->op_type != OP_CONST)
5635 rop = (UNOP*)((BINOP*)o)->op_first;
5636 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
5638 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
5639 if (!SvOBJECT(lexname))
5641 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
5642 if (!fields || !GvHV(*fields))
5644 svp = &((SVOP*)((BINOP*)o)->op_last)->op_sv;
5645 key = SvPV(*svp, keylen);
5646 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
5648 croak("No such field \"%s\" in variable %s of type %s",
5649 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
5651 ind = SvIV(*indsvp);
5653 croak("Bad index while coercing array into hash");
5654 rop->op_type = OP_RV2AV;
5655 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
5656 o->op_type = OP_AELEM;
5657 o->op_ppaddr = PL_ppaddr[OP_AELEM];
5659 *svp = newSViv(ind);
5664 o->op_seq = PL_op_seqmax++;