3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 **ptr = (I32 **) op;
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", Nullop" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
165 SV* tmpsv = sv_newmortal();
166 gv_efullname3(tmpsv, gv, Nullch);
167 return SvPV(tmpsv,n_a);
171 S_no_fh_allowed(pTHX_ OP *o)
173 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
179 S_too_few_arguments(pTHX_ OP *o, const char *name)
181 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
186 S_too_many_arguments(pTHX_ OP *o, const char *name)
188 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
193 S_bad_type(pTHX_ I32 n, const char *t, const char *name, OP *kid)
195 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
196 (int)n, name, t, OP_DESC(kid)));
200 S_no_bareword_allowed(pTHX_ OP *o)
202 qerror(Perl_mess(aTHX_
203 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
207 /* "register" allocation */
210 Perl_allocmy(pTHX_ char *name)
214 /* complain about "my $<special_var>" etc etc */
215 if (!(PL_in_my == KEY_our ||
217 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
218 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
220 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
221 /* 1999-02-27 mjd@plover.com */
223 p = strchr(name, '\0');
224 /* The next block assumes the buffer is at least 205 chars
225 long. At present, it's always at least 256 chars. */
227 strcpy(name+200, "...");
233 /* Move everything else down one character */
234 for (; p-name > 2; p--)
236 name[2] = toCTRL(name[1]);
239 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
242 /* check for duplicate declaration */
244 (bool)(PL_in_my == KEY_our),
245 (PL_curstash ? PL_curstash : PL_defstash)
248 if (PL_in_my_stash && *name != '$') {
249 yyerror(Perl_form(aTHX_
250 "Can't declare class for non-scalar %s in \"%s\"",
251 name, PL_in_my == KEY_our ? "our" : "my"));
254 /* allocate a spare slot and store the name in that slot */
256 off = pad_add_name(name,
259 /* $_ is always in main::, even with our */
260 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
271 Perl_op_free(pTHX_ OP *o)
273 register OP *kid, *nextkid;
277 if (!o || o->op_static)
280 if (o->op_private & OPpREFCOUNTED) {
281 switch (o->op_type) {
289 refcnt = OpREFCNT_dec(o);
299 if (o->op_flags & OPf_KIDS) {
300 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
301 nextkid = kid->op_sibling; /* Get before next freeing kid */
307 type = (OPCODE)o->op_targ;
309 /* COP* is not cleared by op_clear() so that we may track line
310 * numbers etc even after null() */
311 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
319 Perl_op_clear(pTHX_ OP *o)
322 switch (o->op_type) {
323 case OP_NULL: /* Was holding old type, if any. */
324 case OP_ENTEREVAL: /* Was holding hints. */
328 if (!(o->op_flags & OPf_REF)
329 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
335 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
336 /* not an OP_PADAV replacement */
338 if (cPADOPo->op_padix > 0) {
339 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
340 * may still exist on the pad */
341 pad_swipe(cPADOPo->op_padix, TRUE);
342 cPADOPo->op_padix = 0;
345 SvREFCNT_dec(cSVOPo->op_sv);
346 cSVOPo->op_sv = Nullsv;
350 case OP_METHOD_NAMED:
352 SvREFCNT_dec(cSVOPo->op_sv);
353 cSVOPo->op_sv = Nullsv;
356 Even if op_clear does a pad_free for the target of the op,
357 pad_free doesn't actually remove the sv that exists in the pad;
358 instead it lives on. This results in that it could be reused as
359 a target later on when the pad was reallocated.
362 pad_swipe(o->op_targ,1);
371 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
375 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
376 SvREFCNT_dec(cSVOPo->op_sv);
377 cSVOPo->op_sv = Nullsv;
380 Safefree(cPVOPo->op_pv);
381 cPVOPo->op_pv = Nullch;
385 op_free(cPMOPo->op_pmreplroot);
389 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
390 /* No GvIN_PAD_off here, because other references may still
391 * exist on the pad */
392 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
395 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
402 HV *pmstash = PmopSTASH(cPMOPo);
403 if (pmstash && SvREFCNT(pmstash)) {
404 PMOP *pmop = HvPMROOT(pmstash);
405 PMOP *lastpmop = NULL;
407 if (cPMOPo == pmop) {
409 lastpmop->op_pmnext = pmop->op_pmnext;
411 HvPMROOT(pmstash) = pmop->op_pmnext;
415 pmop = pmop->op_pmnext;
418 PmopSTASH_free(cPMOPo);
420 cPMOPo->op_pmreplroot = Nullop;
421 /* we use the "SAFE" version of the PM_ macros here
422 * since sv_clean_all might release some PMOPs
423 * after PL_regex_padav has been cleared
424 * and the clearing of PL_regex_padav needs to
425 * happen before sv_clean_all
427 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
428 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
430 if(PL_regex_pad) { /* We could be in destruction */
431 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
432 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
433 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
440 if (o->op_targ > 0) {
441 pad_free(o->op_targ);
447 S_cop_free(pTHX_ COP* cop)
449 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
452 if (! specialWARN(cop->cop_warnings))
453 SvREFCNT_dec(cop->cop_warnings);
454 if (! specialCopIO(cop->cop_io)) {
458 char *s = SvPV(cop->cop_io,len);
459 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
462 SvREFCNT_dec(cop->cop_io);
468 Perl_op_null(pTHX_ OP *o)
470 if (o->op_type == OP_NULL)
473 o->op_targ = o->op_type;
474 o->op_type = OP_NULL;
475 o->op_ppaddr = PL_ppaddr[OP_NULL];
479 Perl_op_refcnt_lock(pTHX)
485 Perl_op_refcnt_unlock(pTHX)
490 /* Contextualizers */
492 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
495 Perl_linklist(pTHX_ OP *o)
502 /* establish postfix order */
503 if (cUNOPo->op_first) {
504 o->op_next = LINKLIST(cUNOPo->op_first);
505 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
507 kid->op_next = LINKLIST(kid->op_sibling);
519 Perl_scalarkids(pTHX_ OP *o)
521 if (o && o->op_flags & OPf_KIDS) {
523 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
530 S_scalarboolean(pTHX_ OP *o)
532 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
533 if (ckWARN(WARN_SYNTAX)) {
534 line_t oldline = CopLINE(PL_curcop);
536 if (PL_copline != NOLINE)
537 CopLINE_set(PL_curcop, PL_copline);
538 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
539 CopLINE_set(PL_curcop, oldline);
546 Perl_scalar(pTHX_ OP *o)
550 /* assumes no premature commitment */
551 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
552 || o->op_type == OP_RETURN)
557 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
559 switch (o->op_type) {
561 scalar(cBINOPo->op_first);
566 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
570 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
571 if (!kPMOP->op_pmreplroot)
572 deprecate_old("implicit split to @_");
580 if (o->op_flags & OPf_KIDS) {
581 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
587 kid = cLISTOPo->op_first;
589 while ((kid = kid->op_sibling)) {
595 WITH_THR(PL_curcop = &PL_compiling);
600 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
606 WITH_THR(PL_curcop = &PL_compiling);
609 if (ckWARN(WARN_VOID))
610 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
616 Perl_scalarvoid(pTHX_ OP *o)
619 const char* useless = 0;
623 if (o->op_type == OP_NEXTSTATE
624 || o->op_type == OP_SETSTATE
625 || o->op_type == OP_DBSTATE
626 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
627 || o->op_targ == OP_SETSTATE
628 || o->op_targ == OP_DBSTATE)))
629 PL_curcop = (COP*)o; /* for warning below */
631 /* assumes no premature commitment */
632 want = o->op_flags & OPf_WANT;
633 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
634 || o->op_type == OP_RETURN)
639 if ((o->op_private & OPpTARGET_MY)
640 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
642 return scalar(o); /* As if inside SASSIGN */
645 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
647 switch (o->op_type) {
649 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
653 if (o->op_flags & OPf_STACKED)
657 if (o->op_private == 4)
729 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
730 useless = OP_DESC(o);
734 kid = cUNOPo->op_first;
735 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
736 kid->op_type != OP_TRANS) {
739 useless = "negative pattern binding (!~)";
746 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
747 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
748 useless = "a variable";
753 if (cSVOPo->op_private & OPpCONST_STRICT)
754 no_bareword_allowed(o);
756 if (ckWARN(WARN_VOID)) {
757 useless = "a constant";
758 /* don't warn on optimised away booleans, eg
759 * use constant Foo, 5; Foo || print; */
760 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
762 /* the constants 0 and 1 are permitted as they are
763 conventionally used as dummies in constructs like
764 1 while some_condition_with_side_effects; */
765 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
767 else if (SvPOK(sv)) {
768 /* perl4's way of mixing documentation and code
769 (before the invention of POD) was based on a
770 trick to mix nroff and perl code. The trick was
771 built upon these three nroff macros being used in
772 void context. The pink camel has the details in
773 the script wrapman near page 319. */
774 if (strnEQ(SvPVX(sv), "di", 2) ||
775 strnEQ(SvPVX(sv), "ds", 2) ||
776 strnEQ(SvPVX(sv), "ig", 2))
781 op_null(o); /* don't execute or even remember it */
785 o->op_type = OP_PREINC; /* pre-increment is faster */
786 o->op_ppaddr = PL_ppaddr[OP_PREINC];
790 o->op_type = OP_PREDEC; /* pre-decrement is faster */
791 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
798 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
803 if (o->op_flags & OPf_STACKED)
810 if (!(o->op_flags & OPf_KIDS))
819 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
826 /* all requires must return a boolean value */
827 o->op_flags &= ~OPf_WANT;
832 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
833 if (!kPMOP->op_pmreplroot)
834 deprecate_old("implicit split to @_");
838 if (useless && ckWARN(WARN_VOID))
839 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
844 Perl_listkids(pTHX_ OP *o)
847 if (o && o->op_flags & OPf_KIDS) {
848 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
855 Perl_list(pTHX_ OP *o)
859 /* assumes no premature commitment */
860 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
861 || o->op_type == OP_RETURN)
866 if ((o->op_private & OPpTARGET_MY)
867 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
869 return o; /* As if inside SASSIGN */
872 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
874 switch (o->op_type) {
877 list(cBINOPo->op_first);
882 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
890 if (!(o->op_flags & OPf_KIDS))
892 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
893 list(cBINOPo->op_first);
894 return gen_constant_list(o);
901 kid = cLISTOPo->op_first;
903 while ((kid = kid->op_sibling)) {
909 WITH_THR(PL_curcop = &PL_compiling);
913 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
919 WITH_THR(PL_curcop = &PL_compiling);
922 /* all requires must return a boolean value */
923 o->op_flags &= ~OPf_WANT;
930 Perl_scalarseq(pTHX_ OP *o)
935 if (o->op_type == OP_LINESEQ ||
936 o->op_type == OP_SCOPE ||
937 o->op_type == OP_LEAVE ||
938 o->op_type == OP_LEAVETRY)
940 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
941 if (kid->op_sibling) {
945 PL_curcop = &PL_compiling;
947 o->op_flags &= ~OPf_PARENS;
948 if (PL_hints & HINT_BLOCK_SCOPE)
949 o->op_flags |= OPf_PARENS;
952 o = newOP(OP_STUB, 0);
957 S_modkids(pTHX_ OP *o, I32 type)
960 if (o && o->op_flags & OPf_KIDS) {
961 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
967 /* Propagate lvalue ("modifiable") context to an op and it's children.
968 * 'type' represents the context type, roughly based on the type of op that
969 * would do the modifying, although local() is represented by OP_NULL.
970 * It's responsible for detecting things that can't be modified, flag
971 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
972 * might have to vivify a reference in $x), and so on.
974 * For example, "$a+1 = 2" would cause mod() to be called with o being
975 * OP_ADD and type being OP_SASSIGN, and would output an error.
979 Perl_mod(pTHX_ OP *o, I32 type)
982 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
985 if (!o || PL_error_count)
988 if ((o->op_private & OPpTARGET_MY)
989 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
994 switch (o->op_type) {
1000 if (!(o->op_private & (OPpCONST_ARYBASE)))
1002 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1003 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1007 SAVEI32(PL_compiling.cop_arybase);
1008 PL_compiling.cop_arybase = 0;
1010 else if (type == OP_REFGEN)
1013 Perl_croak(aTHX_ "That use of $[ is unsupported");
1016 if (o->op_flags & OPf_PARENS)
1020 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1021 !(o->op_flags & OPf_STACKED)) {
1022 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1023 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1024 assert(cUNOPo->op_first->op_type == OP_NULL);
1025 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1028 else if (o->op_private & OPpENTERSUB_NOMOD)
1030 else { /* lvalue subroutine call */
1031 o->op_private |= OPpLVAL_INTRO;
1032 PL_modcount = RETURN_UNLIMITED_NUMBER;
1033 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1034 /* Backward compatibility mode: */
1035 o->op_private |= OPpENTERSUB_INARGS;
1038 else { /* Compile-time error message: */
1039 OP *kid = cUNOPo->op_first;
1043 if (kid->op_type == OP_PUSHMARK)
1045 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1047 "panic: unexpected lvalue entersub "
1048 "args: type/targ %ld:%"UVuf,
1049 (long)kid->op_type, (UV)kid->op_targ);
1050 kid = kLISTOP->op_first;
1052 while (kid->op_sibling)
1053 kid = kid->op_sibling;
1054 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1056 if (kid->op_type == OP_METHOD_NAMED
1057 || kid->op_type == OP_METHOD)
1061 NewOp(1101, newop, 1, UNOP);
1062 newop->op_type = OP_RV2CV;
1063 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1064 newop->op_first = Nullop;
1065 newop->op_next = (OP*)newop;
1066 kid->op_sibling = (OP*)newop;
1067 newop->op_private |= OPpLVAL_INTRO;
1071 if (kid->op_type != OP_RV2CV)
1073 "panic: unexpected lvalue entersub "
1074 "entry via type/targ %ld:%"UVuf,
1075 (long)kid->op_type, (UV)kid->op_targ);
1076 kid->op_private |= OPpLVAL_INTRO;
1077 break; /* Postpone until runtime */
1081 kid = kUNOP->op_first;
1082 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1083 kid = kUNOP->op_first;
1084 if (kid->op_type == OP_NULL)
1086 "Unexpected constant lvalue entersub "
1087 "entry via type/targ %ld:%"UVuf,
1088 (long)kid->op_type, (UV)kid->op_targ);
1089 if (kid->op_type != OP_GV) {
1090 /* Restore RV2CV to check lvalueness */
1092 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1093 okid->op_next = kid->op_next;
1094 kid->op_next = okid;
1097 okid->op_next = Nullop;
1098 okid->op_type = OP_RV2CV;
1100 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1101 okid->op_private |= OPpLVAL_INTRO;
1105 cv = GvCV(kGVOP_gv);
1115 /* grep, foreach, subcalls, refgen */
1116 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1118 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1119 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1121 : (o->op_type == OP_ENTERSUB
1122 ? "non-lvalue subroutine call"
1124 type ? PL_op_desc[type] : "local"));
1138 case OP_RIGHT_SHIFT:
1147 if (!(o->op_flags & OPf_STACKED))
1154 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1160 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1161 PL_modcount = RETURN_UNLIMITED_NUMBER;
1162 return o; /* Treat \(@foo) like ordinary list. */
1166 if (scalar_mod_type(o, type))
1168 ref(cUNOPo->op_first, o->op_type);
1172 if (type == OP_LEAVESUBLV)
1173 o->op_private |= OPpMAYBE_LVSUB;
1179 PL_modcount = RETURN_UNLIMITED_NUMBER;
1182 ref(cUNOPo->op_first, o->op_type);
1187 PL_hints |= HINT_BLOCK_SCOPE;
1202 PL_modcount = RETURN_UNLIMITED_NUMBER;
1203 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1204 return o; /* Treat \(@foo) like ordinary list. */
1205 if (scalar_mod_type(o, type))
1207 if (type == OP_LEAVESUBLV)
1208 o->op_private |= OPpMAYBE_LVSUB;
1212 if (!type) /* local() */
1213 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1214 PAD_COMPNAME_PV(o->op_targ));
1222 if (type != OP_SASSIGN)
1226 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1231 if (type == OP_LEAVESUBLV)
1232 o->op_private |= OPpMAYBE_LVSUB;
1234 pad_free(o->op_targ);
1235 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1236 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1237 if (o->op_flags & OPf_KIDS)
1238 mod(cBINOPo->op_first->op_sibling, type);
1243 ref(cBINOPo->op_first, o->op_type);
1244 if (type == OP_ENTERSUB &&
1245 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1246 o->op_private |= OPpLVAL_DEFER;
1247 if (type == OP_LEAVESUBLV)
1248 o->op_private |= OPpMAYBE_LVSUB;
1258 if (o->op_flags & OPf_KIDS)
1259 mod(cLISTOPo->op_last, type);
1264 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1266 else if (!(o->op_flags & OPf_KIDS))
1268 if (o->op_targ != OP_LIST) {
1269 mod(cBINOPo->op_first, type);
1275 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1280 if (type != OP_LEAVESUBLV)
1282 break; /* mod()ing was handled by ck_return() */
1285 /* [20011101.069] File test operators interpret OPf_REF to mean that
1286 their argument is a filehandle; thus \stat(".") should not set
1288 if (type == OP_REFGEN &&
1289 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1292 if (type != OP_LEAVESUBLV)
1293 o->op_flags |= OPf_MOD;
1295 if (type == OP_AASSIGN || type == OP_SASSIGN)
1296 o->op_flags |= OPf_SPECIAL|OPf_REF;
1297 else if (!type) { /* local() */
1300 o->op_private |= OPpLVAL_INTRO;
1301 o->op_flags &= ~OPf_SPECIAL;
1302 PL_hints |= HINT_BLOCK_SCOPE;
1307 if (ckWARN(WARN_SYNTAX)) {
1308 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1309 "Useless localization of %s", OP_DESC(o));
1313 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1314 && type != OP_LEAVESUBLV)
1315 o->op_flags |= OPf_REF;
1320 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1324 if (o->op_type == OP_RV2GV)
1348 case OP_RIGHT_SHIFT:
1367 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1369 switch (o->op_type) {
1377 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1390 Perl_refkids(pTHX_ OP *o, I32 type)
1393 if (o && o->op_flags & OPf_KIDS) {
1394 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1401 Perl_ref(pTHX_ OP *o, I32 type)
1405 if (!o || PL_error_count)
1408 switch (o->op_type) {
1410 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1411 !(o->op_flags & OPf_STACKED)) {
1412 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1413 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1414 assert(cUNOPo->op_first->op_type == OP_NULL);
1415 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1416 o->op_flags |= OPf_SPECIAL;
1421 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1425 if (type == OP_DEFINED)
1426 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1427 ref(cUNOPo->op_first, o->op_type);
1430 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1431 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1432 : type == OP_RV2HV ? OPpDEREF_HV
1434 o->op_flags |= OPf_MOD;
1439 o->op_flags |= OPf_MOD; /* XXX ??? */
1444 o->op_flags |= OPf_REF;
1447 if (type == OP_DEFINED)
1448 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1449 ref(cUNOPo->op_first, o->op_type);
1454 o->op_flags |= OPf_REF;
1459 if (!(o->op_flags & OPf_KIDS))
1461 ref(cBINOPo->op_first, type);
1465 ref(cBINOPo->op_first, o->op_type);
1466 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1467 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1468 : type == OP_RV2HV ? OPpDEREF_HV
1470 o->op_flags |= OPf_MOD;
1478 if (!(o->op_flags & OPf_KIDS))
1480 ref(cLISTOPo->op_last, type);
1490 S_dup_attrlist(pTHX_ OP *o)
1494 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1495 * where the first kid is OP_PUSHMARK and the remaining ones
1496 * are OP_CONST. We need to push the OP_CONST values.
1498 if (o->op_type == OP_CONST)
1499 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1501 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1502 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1503 if (o->op_type == OP_CONST)
1504 rop = append_elem(OP_LIST, rop,
1505 newSVOP(OP_CONST, o->op_flags,
1506 SvREFCNT_inc(cSVOPo->op_sv)));
1513 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1517 /* fake up C<use attributes $pkg,$rv,@attrs> */
1518 ENTER; /* need to protect against side-effects of 'use' */
1521 stashsv = newSVpv(HvNAME(stash), 0);
1523 stashsv = &PL_sv_no;
1525 #define ATTRSMODULE "attributes"
1526 #define ATTRSMODULE_PM "attributes.pm"
1530 /* Don't force the C<use> if we don't need it. */
1531 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1532 sizeof(ATTRSMODULE_PM)-1, 0);
1533 if (svp && *svp != &PL_sv_undef)
1534 ; /* already in %INC */
1536 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1537 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1541 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1542 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1544 prepend_elem(OP_LIST,
1545 newSVOP(OP_CONST, 0, stashsv),
1546 prepend_elem(OP_LIST,
1547 newSVOP(OP_CONST, 0,
1549 dup_attrlist(attrs))));
1555 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1557 OP *pack, *imop, *arg;
1563 assert(target->op_type == OP_PADSV ||
1564 target->op_type == OP_PADHV ||
1565 target->op_type == OP_PADAV);
1567 /* Ensure that attributes.pm is loaded. */
1568 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1570 /* Need package name for method call. */
1571 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1573 /* Build up the real arg-list. */
1575 stashsv = newSVpv(HvNAME(stash), 0);
1577 stashsv = &PL_sv_no;
1578 arg = newOP(OP_PADSV, 0);
1579 arg->op_targ = target->op_targ;
1580 arg = prepend_elem(OP_LIST,
1581 newSVOP(OP_CONST, 0, stashsv),
1582 prepend_elem(OP_LIST,
1583 newUNOP(OP_REFGEN, 0,
1584 mod(arg, OP_REFGEN)),
1585 dup_attrlist(attrs)));
1587 /* Fake up a method call to import */
1588 meth = newSVpvn("import", 6);
1589 (void)SvUPGRADE(meth, SVt_PVIV);
1590 (void)SvIOK_on(meth);
1591 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1592 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1593 append_elem(OP_LIST,
1594 prepend_elem(OP_LIST, pack, list(arg)),
1595 newSVOP(OP_METHOD_NAMED, 0, meth)));
1596 imop->op_private |= OPpENTERSUB_NOMOD;
1598 /* Combine the ops. */
1599 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1603 =notfor apidoc apply_attrs_string
1605 Attempts to apply a list of attributes specified by the C<attrstr> and
1606 C<len> arguments to the subroutine identified by the C<cv> argument which
1607 is expected to be associated with the package identified by the C<stashpv>
1608 argument (see L<attributes>). It gets this wrong, though, in that it
1609 does not correctly identify the boundaries of the individual attribute
1610 specifications within C<attrstr>. This is not really intended for the
1611 public API, but has to be listed here for systems such as AIX which
1612 need an explicit export list for symbols. (It's called from XS code
1613 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1614 to respect attribute syntax properly would be welcome.
1620 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1621 char *attrstr, STRLEN len)
1626 len = strlen(attrstr);
1630 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1632 char *sstr = attrstr;
1633 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1634 attrs = append_elem(OP_LIST, attrs,
1635 newSVOP(OP_CONST, 0,
1636 newSVpvn(sstr, attrstr-sstr)));
1640 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1641 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1642 Nullsv, prepend_elem(OP_LIST,
1643 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1644 prepend_elem(OP_LIST,
1645 newSVOP(OP_CONST, 0,
1651 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1656 if (!o || PL_error_count)
1660 if (type == OP_LIST) {
1661 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1662 my_kid(kid, attrs, imopsp);
1663 } else if (type == OP_UNDEF) {
1665 } else if (type == OP_RV2SV || /* "our" declaration */
1667 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1668 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1669 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1670 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1672 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1674 PL_in_my_stash = Nullhv;
1675 apply_attrs(GvSTASH(gv),
1676 (type == OP_RV2SV ? GvSV(gv) :
1677 type == OP_RV2AV ? (SV*)GvAV(gv) :
1678 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1681 o->op_private |= OPpOUR_INTRO;
1684 else if (type != OP_PADSV &&
1687 type != OP_PUSHMARK)
1689 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1691 PL_in_my == KEY_our ? "our" : "my"));
1694 else if (attrs && type != OP_PUSHMARK) {
1698 PL_in_my_stash = Nullhv;
1700 /* check for C<my Dog $spot> when deciding package */
1701 stash = PAD_COMPNAME_TYPE(o->op_targ);
1703 stash = PL_curstash;
1704 apply_attrs_my(stash, o, attrs, imopsp);
1706 o->op_flags |= OPf_MOD;
1707 o->op_private |= OPpLVAL_INTRO;
1712 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1715 int maybe_scalar = 0;
1717 /* [perl #17376]: this appears to be premature, and results in code such as
1718 C< our(%x); > executing in list mode rather than void mode */
1720 if (o->op_flags & OPf_PARENS)
1729 o = my_kid(o, attrs, &rops);
1731 if (maybe_scalar && o->op_type == OP_PADSV) {
1732 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1733 o->op_private |= OPpLVAL_INTRO;
1736 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1739 PL_in_my_stash = Nullhv;
1744 Perl_my(pTHX_ OP *o)
1746 return my_attrs(o, Nullop);
1750 Perl_sawparens(pTHX_ OP *o)
1753 o->op_flags |= OPf_PARENS;
1758 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1763 if (ckWARN(WARN_MISC) &&
1764 (left->op_type == OP_RV2AV ||
1765 left->op_type == OP_RV2HV ||
1766 left->op_type == OP_PADAV ||
1767 left->op_type == OP_PADHV)) {
1768 const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1769 right->op_type == OP_TRANS)
1770 ? right->op_type : OP_MATCH];
1771 const char *sample = ((left->op_type == OP_RV2AV ||
1772 left->op_type == OP_PADAV)
1773 ? "@array" : "%hash");
1774 Perl_warner(aTHX_ packWARN(WARN_MISC),
1775 "Applying %s to %s will act on scalar(%s)",
1776 desc, sample, sample);
1779 if (right->op_type == OP_CONST &&
1780 cSVOPx(right)->op_private & OPpCONST_BARE &&
1781 cSVOPx(right)->op_private & OPpCONST_STRICT)
1783 no_bareword_allowed(right);
1786 ismatchop = right->op_type == OP_MATCH ||
1787 right->op_type == OP_SUBST ||
1788 right->op_type == OP_TRANS;
1789 if (ismatchop && right->op_private & OPpTARGET_MY) {
1791 right->op_private &= ~OPpTARGET_MY;
1793 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1794 right->op_flags |= OPf_STACKED;
1795 if (right->op_type != OP_MATCH &&
1796 ! (right->op_type == OP_TRANS &&
1797 right->op_private & OPpTRANS_IDENTICAL))
1798 left = mod(left, right->op_type);
1799 if (right->op_type == OP_TRANS)
1800 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1802 o = prepend_elem(right->op_type, scalar(left), right);
1804 return newUNOP(OP_NOT, 0, scalar(o));
1808 return bind_match(type, left,
1809 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1813 Perl_invert(pTHX_ OP *o)
1817 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1818 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1822 Perl_scope(pTHX_ OP *o)
1825 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1826 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1827 o->op_type = OP_LEAVE;
1828 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1830 else if (o->op_type == OP_LINESEQ) {
1832 o->op_type = OP_SCOPE;
1833 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1834 kid = ((LISTOP*)o)->op_first;
1835 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1839 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1844 /* XXX kept for BINCOMPAT only */
1846 Perl_save_hints(pTHX)
1848 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1852 Perl_block_start(pTHX_ int full)
1854 const int retval = PL_savestack_ix;
1855 pad_block_start(full);
1857 PL_hints &= ~HINT_BLOCK_SCOPE;
1858 SAVESPTR(PL_compiling.cop_warnings);
1859 if (! specialWARN(PL_compiling.cop_warnings)) {
1860 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1861 SAVEFREESV(PL_compiling.cop_warnings) ;
1863 SAVESPTR(PL_compiling.cop_io);
1864 if (! specialCopIO(PL_compiling.cop_io)) {
1865 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1866 SAVEFREESV(PL_compiling.cop_io) ;
1872 Perl_block_end(pTHX_ I32 floor, OP *seq)
1874 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1875 OP* retval = scalarseq(seq);
1877 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1879 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1887 I32 offset = pad_findmy("$_");
1888 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1889 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1892 OP *o = newOP(OP_PADSV, 0);
1893 o->op_targ = offset;
1899 Perl_newPROG(pTHX_ OP *o)
1904 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1905 ((PL_in_eval & EVAL_KEEPERR)
1906 ? OPf_SPECIAL : 0), o);
1907 PL_eval_start = linklist(PL_eval_root);
1908 PL_eval_root->op_private |= OPpREFCOUNTED;
1909 OpREFCNT_set(PL_eval_root, 1);
1910 PL_eval_root->op_next = 0;
1911 CALL_PEEP(PL_eval_start);
1914 if (o->op_type == OP_STUB) {
1915 PL_comppad_name = 0;
1920 PL_main_root = scope(sawparens(scalarvoid(o)));
1921 PL_curcop = &PL_compiling;
1922 PL_main_start = LINKLIST(PL_main_root);
1923 PL_main_root->op_private |= OPpREFCOUNTED;
1924 OpREFCNT_set(PL_main_root, 1);
1925 PL_main_root->op_next = 0;
1926 CALL_PEEP(PL_main_start);
1929 /* Register with debugger */
1931 CV *cv = get_cv("DB::postponed", FALSE);
1935 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1937 call_sv((SV*)cv, G_DISCARD);
1944 Perl_localize(pTHX_ OP *o, I32 lex)
1946 if (o->op_flags & OPf_PARENS)
1947 /* [perl #17376]: this appears to be premature, and results in code such as
1948 C< our(%x); > executing in list mode rather than void mode */
1955 if (ckWARN(WARN_PARENTHESIS)
1956 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1958 char *s = PL_bufptr;
1961 /* some heuristics to detect a potential error */
1962 while (*s && (strchr(", \t\n", *s)))
1966 if (*s && strchr("@$%*", *s) && *++s
1967 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1970 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1972 while (*s && (strchr(", \t\n", *s)))
1978 if (sigil && (*s == ';' || *s == '=')) {
1979 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1980 "Parentheses missing around \"%s\" list",
1981 lex ? (PL_in_my == KEY_our ? "our" : "my")
1989 o = mod(o, OP_NULL); /* a bit kludgey */
1991 PL_in_my_stash = Nullhv;
1996 Perl_jmaybe(pTHX_ OP *o)
1998 if (o->op_type == OP_LIST) {
2000 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2001 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2007 Perl_fold_constants(pTHX_ register OP *o)
2010 I32 type = o->op_type;
2013 if (PL_opargs[type] & OA_RETSCALAR)
2015 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2016 o->op_targ = pad_alloc(type, SVs_PADTMP);
2018 /* integerize op, unless it happens to be C<-foo>.
2019 * XXX should pp_i_negate() do magic string negation instead? */
2020 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2021 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2022 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2024 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2027 if (!(PL_opargs[type] & OA_FOLDCONST))
2032 /* XXX might want a ck_negate() for this */
2033 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2045 /* XXX what about the numeric ops? */
2046 if (PL_hints & HINT_LOCALE)
2051 goto nope; /* Don't try to run w/ errors */
2053 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2054 if ((curop->op_type != OP_CONST ||
2055 (curop->op_private & OPpCONST_BARE)) &&
2056 curop->op_type != OP_LIST &&
2057 curop->op_type != OP_SCALAR &&
2058 curop->op_type != OP_NULL &&
2059 curop->op_type != OP_PUSHMARK)
2065 curop = LINKLIST(o);
2069 sv = *(PL_stack_sp--);
2070 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2071 pad_swipe(o->op_targ, FALSE);
2072 else if (SvTEMP(sv)) { /* grab mortal temp? */
2073 (void)SvREFCNT_inc(sv);
2077 if (type == OP_RV2GV)
2078 return newGVOP(OP_GV, 0, (GV*)sv);
2079 return newSVOP(OP_CONST, 0, sv);
2086 Perl_gen_constant_list(pTHX_ register OP *o)
2089 I32 oldtmps_floor = PL_tmps_floor;
2093 return o; /* Don't attempt to run with errors */
2095 PL_op = curop = LINKLIST(o);
2102 PL_tmps_floor = oldtmps_floor;
2104 o->op_type = OP_RV2AV;
2105 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2106 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2107 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2108 o->op_opt = 0; /* needs to be revisited in peep() */
2109 curop = ((UNOP*)o)->op_first;
2110 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2117 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2119 if (!o || o->op_type != OP_LIST)
2120 o = newLISTOP(OP_LIST, 0, o, Nullop);
2122 o->op_flags &= ~OPf_WANT;
2124 if (!(PL_opargs[type] & OA_MARK))
2125 op_null(cLISTOPo->op_first);
2127 o->op_type = (OPCODE)type;
2128 o->op_ppaddr = PL_ppaddr[type];
2129 o->op_flags |= flags;
2131 o = CHECKOP(type, o);
2132 if (o->op_type != type)
2135 return fold_constants(o);
2138 /* List constructors */
2141 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2149 if (first->op_type != type
2150 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2152 return newLISTOP(type, 0, first, last);
2155 if (first->op_flags & OPf_KIDS)
2156 ((LISTOP*)first)->op_last->op_sibling = last;
2158 first->op_flags |= OPf_KIDS;
2159 ((LISTOP*)first)->op_first = last;
2161 ((LISTOP*)first)->op_last = last;
2166 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2174 if (first->op_type != type)
2175 return prepend_elem(type, (OP*)first, (OP*)last);
2177 if (last->op_type != type)
2178 return append_elem(type, (OP*)first, (OP*)last);
2180 first->op_last->op_sibling = last->op_first;
2181 first->op_last = last->op_last;
2182 first->op_flags |= (last->op_flags & OPf_KIDS);
2190 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2198 if (last->op_type == type) {
2199 if (type == OP_LIST) { /* already a PUSHMARK there */
2200 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2201 ((LISTOP*)last)->op_first->op_sibling = first;
2202 if (!(first->op_flags & OPf_PARENS))
2203 last->op_flags &= ~OPf_PARENS;
2206 if (!(last->op_flags & OPf_KIDS)) {
2207 ((LISTOP*)last)->op_last = first;
2208 last->op_flags |= OPf_KIDS;
2210 first->op_sibling = ((LISTOP*)last)->op_first;
2211 ((LISTOP*)last)->op_first = first;
2213 last->op_flags |= OPf_KIDS;
2217 return newLISTOP(type, 0, first, last);
2223 Perl_newNULLLIST(pTHX)
2225 return newOP(OP_STUB, 0);
2229 Perl_force_list(pTHX_ OP *o)
2231 if (!o || o->op_type != OP_LIST)
2232 o = newLISTOP(OP_LIST, 0, o, Nullop);
2238 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2242 NewOp(1101, listop, 1, LISTOP);
2244 listop->op_type = (OPCODE)type;
2245 listop->op_ppaddr = PL_ppaddr[type];
2248 listop->op_flags = (U8)flags;
2252 else if (!first && last)
2255 first->op_sibling = last;
2256 listop->op_first = first;
2257 listop->op_last = last;
2258 if (type == OP_LIST) {
2260 pushop = newOP(OP_PUSHMARK, 0);
2261 pushop->op_sibling = first;
2262 listop->op_first = pushop;
2263 listop->op_flags |= OPf_KIDS;
2265 listop->op_last = pushop;
2268 return CHECKOP(type, listop);
2272 Perl_newOP(pTHX_ I32 type, I32 flags)
2275 NewOp(1101, o, 1, OP);
2276 o->op_type = (OPCODE)type;
2277 o->op_ppaddr = PL_ppaddr[type];
2278 o->op_flags = (U8)flags;
2281 o->op_private = (U8)(0 | (flags >> 8));
2282 if (PL_opargs[type] & OA_RETSCALAR)
2284 if (PL_opargs[type] & OA_TARGET)
2285 o->op_targ = pad_alloc(type, SVs_PADTMP);
2286 return CHECKOP(type, o);
2290 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2295 first = newOP(OP_STUB, 0);
2296 if (PL_opargs[type] & OA_MARK)
2297 first = force_list(first);
2299 NewOp(1101, unop, 1, UNOP);
2300 unop->op_type = (OPCODE)type;
2301 unop->op_ppaddr = PL_ppaddr[type];
2302 unop->op_first = first;
2303 unop->op_flags = flags | OPf_KIDS;
2304 unop->op_private = (U8)(1 | (flags >> 8));
2305 unop = (UNOP*) CHECKOP(type, unop);
2309 return fold_constants((OP *) unop);
2313 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2316 NewOp(1101, binop, 1, BINOP);
2319 first = newOP(OP_NULL, 0);
2321 binop->op_type = (OPCODE)type;
2322 binop->op_ppaddr = PL_ppaddr[type];
2323 binop->op_first = first;
2324 binop->op_flags = flags | OPf_KIDS;
2327 binop->op_private = (U8)(1 | (flags >> 8));
2330 binop->op_private = (U8)(2 | (flags >> 8));
2331 first->op_sibling = last;
2334 binop = (BINOP*)CHECKOP(type, binop);
2335 if (binop->op_next || binop->op_type != (OPCODE)type)
2338 binop->op_last = binop->op_first->op_sibling;
2340 return fold_constants((OP *)binop);
2344 uvcompare(const void *a, const void *b)
2346 if (*((const UV *)a) < (*(const UV *)b))
2348 if (*((const UV *)a) > (*(const UV *)b))
2350 if (*((const UV *)a+1) < (*(const UV *)b+1))
2352 if (*((const UV *)a+1) > (*(const UV *)b+1))
2358 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2360 SV *tstr = ((SVOP*)expr)->op_sv;
2361 SV *rstr = ((SVOP*)repl)->op_sv;
2364 U8 *t = (U8*)SvPV(tstr, tlen);
2365 U8 *r = (U8*)SvPV(rstr, rlen);
2372 register short *tbl;
2374 PL_hints |= HINT_BLOCK_SCOPE;
2375 complement = o->op_private & OPpTRANS_COMPLEMENT;
2376 del = o->op_private & OPpTRANS_DELETE;
2377 squash = o->op_private & OPpTRANS_SQUASH;
2380 o->op_private |= OPpTRANS_FROM_UTF;
2383 o->op_private |= OPpTRANS_TO_UTF;
2385 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2386 SV* listsv = newSVpvn("# comment\n",10);
2388 U8* tend = t + tlen;
2389 U8* rend = r + rlen;
2403 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2404 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2410 tsave = t = bytes_to_utf8(t, &len);
2413 if (!to_utf && rlen) {
2415 rsave = r = bytes_to_utf8(r, &len);
2419 /* There are several snags with this code on EBCDIC:
2420 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2421 2. scan_const() in toke.c has encoded chars in native encoding which makes
2422 ranges at least in EBCDIC 0..255 range the bottom odd.
2426 U8 tmpbuf[UTF8_MAXBYTES+1];
2429 New(1109, cp, 2*tlen, UV);
2431 transv = newSVpvn("",0);
2433 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2435 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2437 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2441 cp[2*i+1] = cp[2*i];
2445 qsort(cp, i, 2*sizeof(UV), uvcompare);
2446 for (j = 0; j < i; j++) {
2448 diff = val - nextmin;
2450 t = uvuni_to_utf8(tmpbuf,nextmin);
2451 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2453 U8 range_mark = UTF_TO_NATIVE(0xff);
2454 t = uvuni_to_utf8(tmpbuf, val - 1);
2455 sv_catpvn(transv, (char *)&range_mark, 1);
2456 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2463 t = uvuni_to_utf8(tmpbuf,nextmin);
2464 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2466 U8 range_mark = UTF_TO_NATIVE(0xff);
2467 sv_catpvn(transv, (char *)&range_mark, 1);
2469 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2470 UNICODE_ALLOW_SUPER);
2471 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2472 t = (U8*)SvPVX(transv);
2473 tlen = SvCUR(transv);
2477 else if (!rlen && !del) {
2478 r = t; rlen = tlen; rend = tend;
2481 if ((!rlen && !del) || t == r ||
2482 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2484 o->op_private |= OPpTRANS_IDENTICAL;
2488 while (t < tend || tfirst <= tlast) {
2489 /* see if we need more "t" chars */
2490 if (tfirst > tlast) {
2491 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2493 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2495 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2502 /* now see if we need more "r" chars */
2503 if (rfirst > rlast) {
2505 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2507 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2509 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2518 rfirst = rlast = 0xffffffff;
2522 /* now see which range will peter our first, if either. */
2523 tdiff = tlast - tfirst;
2524 rdiff = rlast - rfirst;
2531 if (rfirst == 0xffffffff) {
2532 diff = tdiff; /* oops, pretend rdiff is infinite */
2534 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2535 (long)tfirst, (long)tlast);
2537 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2541 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2542 (long)tfirst, (long)(tfirst + diff),
2545 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2546 (long)tfirst, (long)rfirst);
2548 if (rfirst + diff > max)
2549 max = rfirst + diff;
2551 grows = (tfirst < rfirst &&
2552 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2564 else if (max > 0xff)
2569 Safefree(cPVOPo->op_pv);
2570 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2571 SvREFCNT_dec(listsv);
2573 SvREFCNT_dec(transv);
2575 if (!del && havefinal && rlen)
2576 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2577 newSVuv((UV)final), 0);
2580 o->op_private |= OPpTRANS_GROWS;
2592 tbl = (short*)cPVOPo->op_pv;
2594 Zero(tbl, 256, short);
2595 for (i = 0; i < (I32)tlen; i++)
2597 for (i = 0, j = 0; i < 256; i++) {
2599 if (j >= (I32)rlen) {
2608 if (i < 128 && r[j] >= 128)
2618 o->op_private |= OPpTRANS_IDENTICAL;
2620 else if (j >= (I32)rlen)
2623 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2624 tbl[0x100] = rlen - j;
2625 for (i=0; i < (I32)rlen - j; i++)
2626 tbl[0x101+i] = r[j+i];
2630 if (!rlen && !del) {
2633 o->op_private |= OPpTRANS_IDENTICAL;
2635 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2636 o->op_private |= OPpTRANS_IDENTICAL;
2638 for (i = 0; i < 256; i++)
2640 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2641 if (j >= (I32)rlen) {
2643 if (tbl[t[i]] == -1)
2649 if (tbl[t[i]] == -1) {
2650 if (t[i] < 128 && r[j] >= 128)
2657 o->op_private |= OPpTRANS_GROWS;
2665 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2669 NewOp(1101, pmop, 1, PMOP);
2670 pmop->op_type = (OPCODE)type;
2671 pmop->op_ppaddr = PL_ppaddr[type];
2672 pmop->op_flags = (U8)flags;
2673 pmop->op_private = (U8)(0 | (flags >> 8));
2675 if (PL_hints & HINT_RE_TAINT)
2676 pmop->op_pmpermflags |= PMf_RETAINT;
2677 if (PL_hints & HINT_LOCALE)
2678 pmop->op_pmpermflags |= PMf_LOCALE;
2679 pmop->op_pmflags = pmop->op_pmpermflags;
2684 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2685 repointer = av_pop((AV*)PL_regex_pad[0]);
2686 pmop->op_pmoffset = SvIV(repointer);
2687 SvREPADTMP_off(repointer);
2688 sv_setiv(repointer,0);
2690 repointer = newSViv(0);
2691 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2692 pmop->op_pmoffset = av_len(PL_regex_padav);
2693 PL_regex_pad = AvARRAY(PL_regex_padav);
2698 /* link into pm list */
2699 if (type != OP_TRANS && PL_curstash) {
2700 pmop->op_pmnext = HvPMROOT(PL_curstash);
2701 HvPMROOT(PL_curstash) = pmop;
2702 PmopSTASH_set(pmop,PL_curstash);
2705 return CHECKOP(type, pmop);
2708 /* Given some sort of match op o, and an expression expr containing a
2709 * pattern, either compile expr into a regex and attach it to o (if it's
2710 * constant), or convert expr into a runtime regcomp op sequence (if it's
2713 * isreg indicates that the pattern is part of a regex construct, eg
2714 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2715 * split "pattern", which aren't. In the former case, expr will be a list
2716 * if the pattern contains more than one term (eg /a$b/) or if it contains
2717 * a replacement, ie s/// or tr///.
2721 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2725 I32 repl_has_vars = 0;
2729 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2730 /* last element in list is the replacement; pop it */
2732 repl = cLISTOPx(expr)->op_last;
2733 kid = cLISTOPx(expr)->op_first;
2734 while (kid->op_sibling != repl)
2735 kid = kid->op_sibling;
2736 kid->op_sibling = Nullop;
2737 cLISTOPx(expr)->op_last = kid;
2740 if (isreg && expr->op_type == OP_LIST &&
2741 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2743 /* convert single element list to element */
2745 expr = cLISTOPx(oe)->op_first->op_sibling;
2746 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2747 cLISTOPx(oe)->op_last = Nullop;
2751 if (o->op_type == OP_TRANS) {
2752 return pmtrans(o, expr, repl);
2755 reglist = isreg && expr->op_type == OP_LIST;
2759 PL_hints |= HINT_BLOCK_SCOPE;
2762 if (expr->op_type == OP_CONST) {
2764 SV *pat = ((SVOP*)expr)->op_sv;
2765 char *p = SvPV(pat, plen);
2766 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2767 sv_setpvn(pat, "\\s+", 3);
2768 p = SvPV(pat, plen);
2769 pm->op_pmflags |= PMf_SKIPWHITE;
2772 pm->op_pmdynflags |= PMdf_UTF8;
2773 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2774 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2775 pm->op_pmflags |= PMf_WHITE;
2779 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2780 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2782 : OP_REGCMAYBE),0,expr);
2784 NewOp(1101, rcop, 1, LOGOP);
2785 rcop->op_type = OP_REGCOMP;
2786 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2787 rcop->op_first = scalar(expr);
2788 rcop->op_flags |= OPf_KIDS
2789 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2790 | (reglist ? OPf_STACKED : 0);
2791 rcop->op_private = 1;
2794 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2796 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2799 /* establish postfix order */
2800 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2802 rcop->op_next = expr;
2803 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2806 rcop->op_next = LINKLIST(expr);
2807 expr->op_next = (OP*)rcop;
2810 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2815 if (pm->op_pmflags & PMf_EVAL) {
2817 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2818 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2820 else if (repl->op_type == OP_CONST)
2824 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2825 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2826 if (curop->op_type == OP_GV) {
2827 GV *gv = cGVOPx_gv(curop);
2829 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2832 else if (curop->op_type == OP_RV2CV)
2834 else if (curop->op_type == OP_RV2SV ||
2835 curop->op_type == OP_RV2AV ||
2836 curop->op_type == OP_RV2HV ||
2837 curop->op_type == OP_RV2GV) {
2838 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2841 else if (curop->op_type == OP_PADSV ||
2842 curop->op_type == OP_PADAV ||
2843 curop->op_type == OP_PADHV ||
2844 curop->op_type == OP_PADANY) {
2847 else if (curop->op_type == OP_PUSHRE)
2848 ; /* Okay here, dangerous in newASSIGNOP */
2858 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2859 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2860 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2861 prepend_elem(o->op_type, scalar(repl), o);
2864 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2865 pm->op_pmflags |= PMf_MAYBE_CONST;
2866 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2868 NewOp(1101, rcop, 1, LOGOP);
2869 rcop->op_type = OP_SUBSTCONT;
2870 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2871 rcop->op_first = scalar(repl);
2872 rcop->op_flags |= OPf_KIDS;
2873 rcop->op_private = 1;
2876 /* establish postfix order */
2877 rcop->op_next = LINKLIST(repl);
2878 repl->op_next = (OP*)rcop;
2880 pm->op_pmreplroot = scalar((OP*)rcop);
2881 pm->op_pmreplstart = LINKLIST(rcop);
2890 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2893 NewOp(1101, svop, 1, SVOP);
2894 svop->op_type = (OPCODE)type;
2895 svop->op_ppaddr = PL_ppaddr[type];
2897 svop->op_next = (OP*)svop;
2898 svop->op_flags = (U8)flags;
2899 if (PL_opargs[type] & OA_RETSCALAR)
2901 if (PL_opargs[type] & OA_TARGET)
2902 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2903 return CHECKOP(type, svop);
2907 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2910 NewOp(1101, padop, 1, PADOP);
2911 padop->op_type = (OPCODE)type;
2912 padop->op_ppaddr = PL_ppaddr[type];
2913 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2914 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2915 PAD_SETSV(padop->op_padix, sv);
2918 padop->op_next = (OP*)padop;
2919 padop->op_flags = (U8)flags;
2920 if (PL_opargs[type] & OA_RETSCALAR)
2922 if (PL_opargs[type] & OA_TARGET)
2923 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2924 return CHECKOP(type, padop);
2928 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2933 return newPADOP(type, flags, SvREFCNT_inc(gv));
2935 return newSVOP(type, flags, SvREFCNT_inc(gv));
2940 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2943 NewOp(1101, pvop, 1, PVOP);
2944 pvop->op_type = (OPCODE)type;
2945 pvop->op_ppaddr = PL_ppaddr[type];
2947 pvop->op_next = (OP*)pvop;
2948 pvop->op_flags = (U8)flags;
2949 if (PL_opargs[type] & OA_RETSCALAR)
2951 if (PL_opargs[type] & OA_TARGET)
2952 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2953 return CHECKOP(type, pvop);
2957 Perl_package(pTHX_ OP *o)
2962 save_hptr(&PL_curstash);
2963 save_item(PL_curstname);
2965 name = SvPV(cSVOPo->op_sv, len);
2966 PL_curstash = gv_stashpvn(name, len, TRUE);
2967 sv_setpvn(PL_curstname, name, len);
2970 PL_hints |= HINT_BLOCK_SCOPE;
2971 PL_copline = NOLINE;
2976 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2982 if (idop->op_type != OP_CONST)
2983 Perl_croak(aTHX_ "Module name must be constant");
2987 if (version != Nullop) {
2988 SV *vesv = ((SVOP*)version)->op_sv;
2990 if (arg == Nullop && !SvNIOKp(vesv)) {
2997 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2998 Perl_croak(aTHX_ "Version number must be constant number");
3000 /* Make copy of idop so we don't free it twice */
3001 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3003 /* Fake up a method call to VERSION */
3004 meth = newSVpvn("VERSION",7);
3005 sv_upgrade(meth, SVt_PVIV);
3006 (void)SvIOK_on(meth);
3007 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3008 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3009 append_elem(OP_LIST,
3010 prepend_elem(OP_LIST, pack, list(version)),
3011 newSVOP(OP_METHOD_NAMED, 0, meth)));
3015 /* Fake up an import/unimport */
3016 if (arg && arg->op_type == OP_STUB)
3017 imop = arg; /* no import on explicit () */
3018 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3019 imop = Nullop; /* use 5.0; */
3024 /* Make copy of idop so we don't free it twice */
3025 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3027 /* Fake up a method call to import/unimport */
3028 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3029 (void)SvUPGRADE(meth, SVt_PVIV);
3030 (void)SvIOK_on(meth);
3031 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3032 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3033 append_elem(OP_LIST,
3034 prepend_elem(OP_LIST, pack, list(arg)),
3035 newSVOP(OP_METHOD_NAMED, 0, meth)));
3038 /* Fake up the BEGIN {}, which does its thing immediately. */
3040 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3043 append_elem(OP_LINESEQ,
3044 append_elem(OP_LINESEQ,
3045 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3046 newSTATEOP(0, Nullch, veop)),
3047 newSTATEOP(0, Nullch, imop) ));
3049 /* The "did you use incorrect case?" warning used to be here.
3050 * The problem is that on case-insensitive filesystems one
3051 * might get false positives for "use" (and "require"):
3052 * "use Strict" or "require CARP" will work. This causes
3053 * portability problems for the script: in case-strict
3054 * filesystems the script will stop working.
3056 * The "incorrect case" warning checked whether "use Foo"
3057 * imported "Foo" to your namespace, but that is wrong, too:
3058 * there is no requirement nor promise in the language that
3059 * a Foo.pm should or would contain anything in package "Foo".
3061 * There is very little Configure-wise that can be done, either:
3062 * the case-sensitivity of the build filesystem of Perl does not
3063 * help in guessing the case-sensitivity of the runtime environment.
3066 PL_hints |= HINT_BLOCK_SCOPE;
3067 PL_copline = NOLINE;
3069 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3073 =head1 Embedding Functions
3075 =for apidoc load_module
3077 Loads the module whose name is pointed to by the string part of name.
3078 Note that the actual module name, not its filename, should be given.
3079 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3080 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3081 (or 0 for no flags). ver, if specified, provides version semantics
3082 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3083 arguments can be used to specify arguments to the module's import()
3084 method, similar to C<use Foo::Bar VERSION LIST>.
3089 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3092 va_start(args, ver);
3093 vload_module(flags, name, ver, &args);
3097 #ifdef PERL_IMPLICIT_CONTEXT
3099 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3103 va_start(args, ver);
3104 vload_module(flags, name, ver, &args);
3110 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3112 OP *modname, *veop, *imop;
3114 modname = newSVOP(OP_CONST, 0, name);
3115 modname->op_private |= OPpCONST_BARE;
3117 veop = newSVOP(OP_CONST, 0, ver);
3121 if (flags & PERL_LOADMOD_NOIMPORT) {
3122 imop = sawparens(newNULLLIST());
3124 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3125 imop = va_arg(*args, OP*);
3130 sv = va_arg(*args, SV*);
3132 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3133 sv = va_arg(*args, SV*);
3137 line_t ocopline = PL_copline;
3138 COP *ocurcop = PL_curcop;
3139 int oexpect = PL_expect;
3141 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3142 veop, modname, imop);
3143 PL_expect = oexpect;
3144 PL_copline = ocopline;
3145 PL_curcop = ocurcop;
3150 Perl_dofile(pTHX_ OP *term)
3155 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3156 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3157 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3159 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3160 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3161 append_elem(OP_LIST, term,
3162 scalar(newUNOP(OP_RV2CV, 0,
3167 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3173 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3175 return newBINOP(OP_LSLICE, flags,
3176 list(force_list(subscript)),
3177 list(force_list(listval)) );
3181 S_list_assignment(pTHX_ register OP *o)
3186 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3187 o = cUNOPo->op_first;
3189 if (o->op_type == OP_COND_EXPR) {
3190 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3191 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3196 yyerror("Assignment to both a list and a scalar");
3200 if (o->op_type == OP_LIST &&
3201 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3202 o->op_private & OPpLVAL_INTRO)
3205 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3206 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3207 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3210 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3213 if (o->op_type == OP_RV2SV)
3220 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3225 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3226 return newLOGOP(optype, 0,
3227 mod(scalar(left), optype),
3228 newUNOP(OP_SASSIGN, 0, scalar(right)));
3231 return newBINOP(optype, OPf_STACKED,
3232 mod(scalar(left), optype), scalar(right));
3236 if (list_assignment(left)) {
3240 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3241 left = mod(left, OP_AASSIGN);
3249 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3250 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3251 && right->op_type == OP_STUB
3252 && (left->op_private & OPpLVAL_INTRO))
3255 left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3258 curop = list(force_list(left));
3259 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3260 o->op_private = (U8)(0 | (flags >> 8));
3262 /* PL_generation sorcery:
3263 * an assignment like ($a,$b) = ($c,$d) is easier than
3264 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3265 * To detect whether there are common vars, the global var
3266 * PL_generation is incremented for each assign op we compile.
3267 * Then, while compiling the assign op, we run through all the
3268 * variables on both sides of the assignment, setting a spare slot
3269 * in each of them to PL_generation. If any of them already have
3270 * that value, we know we've got commonality. We could use a
3271 * single bit marker, but then we'd have to make 2 passes, first
3272 * to clear the flag, then to test and set it. To find somewhere
3273 * to store these values, evil chicanery is done with SvCUR().
3276 if (!(left->op_private & OPpLVAL_INTRO)) {
3279 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3280 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3281 if (curop->op_type == OP_GV) {
3282 GV *gv = cGVOPx_gv(curop);
3283 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3285 SvCUR(gv) = PL_generation;
3287 else if (curop->op_type == OP_PADSV ||
3288 curop->op_type == OP_PADAV ||
3289 curop->op_type == OP_PADHV ||
3290 curop->op_type == OP_PADANY)
3292 if (PAD_COMPNAME_GEN(curop->op_targ)
3293 == (STRLEN)PL_generation)
3295 PAD_COMPNAME_GEN(curop->op_targ)
3299 else if (curop->op_type == OP_RV2CV)
3301 else if (curop->op_type == OP_RV2SV ||
3302 curop->op_type == OP_RV2AV ||
3303 curop->op_type == OP_RV2HV ||
3304 curop->op_type == OP_RV2GV) {
3305 if (lastop->op_type != OP_GV) /* funny deref? */
3308 else if (curop->op_type == OP_PUSHRE) {
3309 if (((PMOP*)curop)->op_pmreplroot) {
3311 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3312 ((PMOP*)curop)->op_pmreplroot));
3314 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3316 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3318 SvCUR(gv) = PL_generation;
3327 o->op_private |= OPpASSIGN_COMMON;
3329 if (right && right->op_type == OP_SPLIT) {
3331 if ((tmpop = ((LISTOP*)right)->op_first) &&
3332 tmpop->op_type == OP_PUSHRE)
3334 PMOP *pm = (PMOP*)tmpop;
3335 if (left->op_type == OP_RV2AV &&
3336 !(left->op_private & OPpLVAL_INTRO) &&
3337 !(o->op_private & OPpASSIGN_COMMON) )
3339 tmpop = ((UNOP*)left)->op_first;
3340 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3342 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3343 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3345 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3346 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3348 pm->op_pmflags |= PMf_ONCE;
3349 tmpop = cUNOPo->op_first; /* to list (nulled) */
3350 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3351 tmpop->op_sibling = Nullop; /* don't free split */
3352 right->op_next = tmpop->op_next; /* fix starting loc */
3353 op_free(o); /* blow off assign */
3354 right->op_flags &= ~OPf_WANT;
3355 /* "I don't know and I don't care." */
3360 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3361 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3363 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3365 sv_setiv(sv, PL_modcount+1);
3373 right = newOP(OP_UNDEF, 0);
3374 if (right->op_type == OP_READLINE) {
3375 right->op_flags |= OPf_STACKED;
3376 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3379 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3380 o = newBINOP(OP_SASSIGN, flags,
3381 scalar(right), mod(scalar(left), OP_SASSIGN) );
3393 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3395 const U32 seq = intro_my();
3398 NewOp(1101, cop, 1, COP);
3399 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3400 cop->op_type = OP_DBSTATE;
3401 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3404 cop->op_type = OP_NEXTSTATE;
3405 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3407 cop->op_flags = (U8)flags;
3408 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3410 cop->op_private |= NATIVE_HINTS;
3412 PL_compiling.op_private = cop->op_private;
3413 cop->op_next = (OP*)cop;
3416 cop->cop_label = label;
3417 PL_hints |= HINT_BLOCK_SCOPE;
3420 cop->cop_arybase = PL_curcop->cop_arybase;
3421 if (specialWARN(PL_curcop->cop_warnings))
3422 cop->cop_warnings = PL_curcop->cop_warnings ;
3424 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3425 if (specialCopIO(PL_curcop->cop_io))
3426 cop->cop_io = PL_curcop->cop_io;
3428 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3431 if (PL_copline == NOLINE)
3432 CopLINE_set(cop, CopLINE(PL_curcop));
3434 CopLINE_set(cop, PL_copline);
3435 PL_copline = NOLINE;
3438 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3440 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3442 CopSTASH_set(cop, PL_curstash);
3444 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3445 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3446 if (svp && *svp != &PL_sv_undef ) {
3447 (void)SvIOK_on(*svp);
3448 SvIVX(*svp) = PTR2IV(cop);
3452 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3457 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3459 return new_logop(type, flags, &first, &other);
3463 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3467 OP *first = *firstp;
3468 OP *other = *otherp;
3470 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3471 return newBINOP(type, flags, scalar(first), scalar(other));
3473 scalarboolean(first);
3474 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3475 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3476 if (type == OP_AND || type == OP_OR) {
3482 first = *firstp = cUNOPo->op_first;
3484 first->op_next = o->op_next;
3485 cUNOPo->op_first = Nullop;
3489 if (first->op_type == OP_CONST) {
3490 if (first->op_private & OPpCONST_STRICT)
3491 no_bareword_allowed(first);
3492 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3493 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3494 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3495 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3496 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3499 if (other->op_type == OP_CONST)
3500 other->op_private |= OPpCONST_SHORTCIRCUIT;
3504 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3506 if ( ! (o2->op_type == OP_LIST
3507 && (( o2 = cUNOPx(o2)->op_first))
3508 && o2->op_type == OP_PUSHMARK
3509 && (( o2 = o2->op_sibling)) )
3512 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3513 || o2->op_type == OP_PADHV)
3514 && o2->op_private & OPpLVAL_INTRO
3515 && ckWARN(WARN_DEPRECATED))
3517 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3518 "Deprecated use of my() in false conditional");
3523 if (first->op_type == OP_CONST)
3524 first->op_private |= OPpCONST_SHORTCIRCUIT;
3528 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3529 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3531 OP *k1 = ((UNOP*)first)->op_first;
3532 OP *k2 = k1->op_sibling;
3534 switch (first->op_type)
3537 if (k2 && k2->op_type == OP_READLINE
3538 && (k2->op_flags & OPf_STACKED)
3539 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3541 warnop = k2->op_type;
3546 if (k1->op_type == OP_READDIR
3547 || k1->op_type == OP_GLOB
3548 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3549 || k1->op_type == OP_EACH)
3551 warnop = ((k1->op_type == OP_NULL)
3552 ? (OPCODE)k1->op_targ : k1->op_type);
3557 line_t oldline = CopLINE(PL_curcop);
3558 CopLINE_set(PL_curcop, PL_copline);
3559 Perl_warner(aTHX_ packWARN(WARN_MISC),
3560 "Value of %s%s can be \"0\"; test with defined()",
3562 ((warnop == OP_READLINE || warnop == OP_GLOB)
3563 ? " construct" : "() operator"));
3564 CopLINE_set(PL_curcop, oldline);
3571 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3572 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3574 NewOp(1101, logop, 1, LOGOP);
3576 logop->op_type = (OPCODE)type;
3577 logop->op_ppaddr = PL_ppaddr[type];
3578 logop->op_first = first;
3579 logop->op_flags = flags | OPf_KIDS;
3580 logop->op_other = LINKLIST(other);
3581 logop->op_private = (U8)(1 | (flags >> 8));
3583 /* establish postfix order */
3584 logop->op_next = LINKLIST(first);
3585 first->op_next = (OP*)logop;
3586 first->op_sibling = other;
3588 CHECKOP(type,logop);
3590 o = newUNOP(OP_NULL, 0, (OP*)logop);
3597 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3604 return newLOGOP(OP_AND, 0, first, trueop);
3606 return newLOGOP(OP_OR, 0, first, falseop);
3608 scalarboolean(first);
3609 if (first->op_type == OP_CONST) {
3610 if (first->op_private & OPpCONST_BARE &&
3611 first->op_private & OPpCONST_STRICT) {
3612 no_bareword_allowed(first);
3614 if (SvTRUE(((SVOP*)first)->op_sv)) {
3625 NewOp(1101, logop, 1, LOGOP);
3626 logop->op_type = OP_COND_EXPR;
3627 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3628 logop->op_first = first;
3629 logop->op_flags = flags | OPf_KIDS;
3630 logop->op_private = (U8)(1 | (flags >> 8));
3631 logop->op_other = LINKLIST(trueop);
3632 logop->op_next = LINKLIST(falseop);
3634 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3637 /* establish postfix order */
3638 start = LINKLIST(first);
3639 first->op_next = (OP*)logop;
3641 first->op_sibling = trueop;
3642 trueop->op_sibling = falseop;
3643 o = newUNOP(OP_NULL, 0, (OP*)logop);
3645 trueop->op_next = falseop->op_next = o;
3652 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3660 NewOp(1101, range, 1, LOGOP);
3662 range->op_type = OP_RANGE;
3663 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3664 range->op_first = left;
3665 range->op_flags = OPf_KIDS;
3666 leftstart = LINKLIST(left);
3667 range->op_other = LINKLIST(right);
3668 range->op_private = (U8)(1 | (flags >> 8));
3670 left->op_sibling = right;
3672 range->op_next = (OP*)range;
3673 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3674 flop = newUNOP(OP_FLOP, 0, flip);
3675 o = newUNOP(OP_NULL, 0, flop);
3677 range->op_next = leftstart;
3679 left->op_next = flip;
3680 right->op_next = flop;
3682 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3683 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3684 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3685 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3687 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3688 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3691 if (!flip->op_private || !flop->op_private)
3692 linklist(o); /* blow off optimizer unless constant */
3698 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3702 const bool once = block && block->op_flags & OPf_SPECIAL &&
3703 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3707 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3708 return block; /* do {} while 0 does once */
3709 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3710 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3711 expr = newUNOP(OP_DEFINED, 0,
3712 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3713 } else if (expr->op_flags & OPf_KIDS) {
3714 const OP *k1 = ((UNOP*)expr)->op_first;
3715 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3716 switch (expr->op_type) {
3718 if (k2 && k2->op_type == OP_READLINE
3719 && (k2->op_flags & OPf_STACKED)
3720 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3721 expr = newUNOP(OP_DEFINED, 0, expr);
3725 if (k1->op_type == OP_READDIR
3726 || k1->op_type == OP_GLOB
3727 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3728 || k1->op_type == OP_EACH)
3729 expr = newUNOP(OP_DEFINED, 0, expr);
3735 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3736 * op, in listop. This is wrong. [perl #27024] */
3738 block = newOP(OP_NULL, 0);
3739 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3740 o = new_logop(OP_AND, 0, &expr, &listop);
3743 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3745 if (once && o != listop)
3746 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3749 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3751 o->op_flags |= flags;
3753 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3758 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3767 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3768 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3769 expr = newUNOP(OP_DEFINED, 0,
3770 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3771 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3772 const OP *k1 = ((UNOP*)expr)->op_first;
3773 const OP *k2 = (k1) ? k1->op_sibling : NULL;
3774 switch (expr->op_type) {
3776 if (k2 && k2->op_type == OP_READLINE
3777 && (k2->op_flags & OPf_STACKED)
3778 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3779 expr = newUNOP(OP_DEFINED, 0, expr);
3783 if (k1->op_type == OP_READDIR
3784 || k1->op_type == OP_GLOB
3785 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3786 || k1->op_type == OP_EACH)
3787 expr = newUNOP(OP_DEFINED, 0, expr);
3793 block = newOP(OP_NULL, 0);
3795 block = scope(block);
3799 next = LINKLIST(cont);
3802 OP *unstack = newOP(OP_UNSTACK, 0);
3805 cont = append_elem(OP_LINESEQ, cont, unstack);
3808 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3809 redo = LINKLIST(listop);
3812 PL_copline = (line_t)whileline;
3814 o = new_logop(OP_AND, 0, &expr, &listop);
3815 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3816 op_free(expr); /* oops, it's a while (0) */
3818 return Nullop; /* listop already freed by new_logop */
3821 ((LISTOP*)listop)->op_last->op_next =
3822 (o == listop ? redo : LINKLIST(o));
3828 NewOp(1101,loop,1,LOOP);
3829 loop->op_type = OP_ENTERLOOP;
3830 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3831 loop->op_private = 0;
3832 loop->op_next = (OP*)loop;
3835 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3837 loop->op_redoop = redo;
3838 loop->op_lastop = o;
3839 o->op_private |= loopflags;
3842 loop->op_nextop = next;
3844 loop->op_nextop = o;
3846 o->op_flags |= flags;
3847 o->op_private |= (flags >> 8);
3852 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3856 PADOFFSET padoff = 0;
3861 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3862 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3863 sv->op_type = OP_RV2GV;
3864 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3866 else if (sv->op_type == OP_PADSV) { /* private variable */
3867 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3868 padoff = sv->op_targ;
3873 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3874 padoff = sv->op_targ;
3876 iterflags |= OPf_SPECIAL;
3881 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3884 const I32 offset = pad_findmy("$_");
3885 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3886 sv = newGVOP(OP_GV, 0, PL_defgv);
3892 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3893 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3894 iterflags |= OPf_STACKED;
3896 else if (expr->op_type == OP_NULL &&
3897 (expr->op_flags & OPf_KIDS) &&
3898 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3900 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3901 * set the STACKED flag to indicate that these values are to be
3902 * treated as min/max values by 'pp_iterinit'.
3904 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3905 LOGOP* range = (LOGOP*) flip->op_first;
3906 OP* left = range->op_first;
3907 OP* right = left->op_sibling;
3910 range->op_flags &= ~OPf_KIDS;
3911 range->op_first = Nullop;
3913 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3914 listop->op_first->op_next = range->op_next;
3915 left->op_next = range->op_other;
3916 right->op_next = (OP*)listop;
3917 listop->op_next = listop->op_first;
3920 expr = (OP*)(listop);
3922 iterflags |= OPf_STACKED;
3925 expr = mod(force_list(expr), OP_GREPSTART);
3929 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3930 append_elem(OP_LIST, expr, scalar(sv))));
3931 assert(!loop->op_next);
3932 /* for my $x () sets OPpLVAL_INTRO;
3933 * for our $x () sets OPpOUR_INTRO */
3934 loop->op_private = (U8)iterpflags;
3935 #ifdef PL_OP_SLAB_ALLOC
3938 NewOp(1234,tmp,1,LOOP);
3939 Copy(loop,tmp,1,LOOP);
3944 Renew(loop, 1, LOOP);
3946 loop->op_targ = padoff;
3947 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3948 PL_copline = forline;
3949 return newSTATEOP(0, label, wop);
3953 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3958 if (type != OP_GOTO || label->op_type == OP_CONST) {
3959 /* "last()" means "last" */
3960 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3961 o = newOP(type, OPf_SPECIAL);
3963 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3964 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3970 /* Check whether it's going to be a goto &function */
3971 if (label->op_type == OP_ENTERSUB
3972 && !(label->op_flags & OPf_STACKED))
3973 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3974 o = newUNOP(type, OPf_STACKED, label);
3976 PL_hints |= HINT_BLOCK_SCOPE;
3981 =for apidoc cv_undef
3983 Clear out all the active components of a CV. This can happen either
3984 by an explicit C<undef &foo>, or by the reference count going to zero.
3985 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3986 children can still follow the full lexical scope chain.
3992 Perl_cv_undef(pTHX_ CV *cv)
3995 if (CvFILE(cv) && !CvXSUB(cv)) {
3996 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3997 Safefree(CvFILE(cv));
4002 if (!CvXSUB(cv) && CvROOT(cv)) {
4004 Perl_croak(aTHX_ "Can't undef active subroutine");
4007 PAD_SAVE_SETNULLPAD();
4009 op_free(CvROOT(cv));
4010 CvROOT(cv) = Nullop;
4013 SvPOK_off((SV*)cv); /* forget prototype */
4018 /* remove CvOUTSIDE unless this is an undef rather than a free */
4019 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4020 if (!CvWEAKOUTSIDE(cv))
4021 SvREFCNT_dec(CvOUTSIDE(cv));
4022 CvOUTSIDE(cv) = Nullcv;
4025 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4031 /* delete all flags except WEAKOUTSIDE */
4032 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4036 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4038 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4039 SV* msg = sv_newmortal();
4043 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4044 sv_setpv(msg, "Prototype mismatch:");
4046 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4048 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4050 Perl_sv_catpv(aTHX_ msg, ": none");
4051 sv_catpv(msg, " vs ");
4053 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4055 sv_catpv(msg, "none");
4056 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4060 static void const_sv_xsub(pTHX_ CV* cv);
4064 =head1 Optree Manipulation Functions
4066 =for apidoc cv_const_sv
4068 If C<cv> is a constant sub eligible for inlining. returns the constant
4069 value returned by the sub. Otherwise, returns NULL.
4071 Constant subs can be created with C<newCONSTSUB> or as described in
4072 L<perlsub/"Constant Functions">.
4077 Perl_cv_const_sv(pTHX_ CV *cv)
4079 if (!cv || !CvCONST(cv))
4081 return (SV*)CvXSUBANY(cv).any_ptr;
4084 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4085 * Can be called in 3 ways:
4088 * look for a single OP_CONST with attached value: return the value
4090 * cv && CvCLONE(cv) && !CvCONST(cv)
4092 * examine the clone prototype, and if contains only a single
4093 * OP_CONST referencing a pad const, or a single PADSV referencing
4094 * an outer lexical, return a non-zero value to indicate the CV is
4095 * a candidate for "constizing" at clone time
4099 * We have just cloned an anon prototype that was marked as a const
4100 * candidiate. Try to grab the current value, and in the case of
4101 * PADSV, ignore it if it has multiple references. Return the value.
4105 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4112 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4113 o = cLISTOPo->op_first->op_sibling;
4115 for (; o; o = o->op_next) {
4116 OPCODE type = o->op_type;
4118 if (sv && o->op_next == o)
4120 if (o->op_next != o) {
4121 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4123 if (type == OP_DBSTATE)
4126 if (type == OP_LEAVESUB || type == OP_RETURN)
4130 if (type == OP_CONST && cSVOPo->op_sv)
4132 else if (cv && type == OP_CONST) {
4133 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4137 else if (cv && type == OP_PADSV) {
4138 if (CvCONST(cv)) { /* newly cloned anon */
4139 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4140 /* the candidate should have 1 ref from this pad and 1 ref
4141 * from the parent */
4142 if (!sv || SvREFCNT(sv) != 2)
4149 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4150 sv = &PL_sv_undef; /* an arbitrary non-null value */
4161 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4172 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4176 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4178 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4182 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4192 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4195 assert(proto->op_type == OP_CONST);
4196 ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4201 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4202 SV *sv = sv_newmortal();
4203 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4204 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4205 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4210 gv = name ? gv_fetchsv(cSVOPo->op_sv,
4211 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4213 : gv_fetchpv(aname ? aname
4214 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4215 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4225 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4226 maximum a prototype before. */
4227 if (SvTYPE(gv) > SVt_NULL) {
4228 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4229 && ckWARN_d(WARN_PROTOTYPE))
4231 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4233 cv_ckproto((CV*)gv, NULL, ps);
4236 sv_setpv((SV*)gv, ps);
4238 sv_setiv((SV*)gv, -1);
4239 SvREFCNT_dec(PL_compcv);
4240 cv = PL_compcv = NULL;
4241 PL_sub_generation++;
4245 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4247 #ifdef GV_UNIQUE_CHECK
4248 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4249 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4253 if (!block || !ps || *ps || attrs)
4256 const_sv = op_const_sv(block, Nullcv);
4259 bool exists = CvROOT(cv) || CvXSUB(cv);
4261 #ifdef GV_UNIQUE_CHECK
4262 if (exists && GvUNIQUE(gv)) {
4263 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4267 /* if the subroutine doesn't exist and wasn't pre-declared
4268 * with a prototype, assume it will be AUTOLOADed,
4269 * skipping the prototype check
4271 if (exists || SvPOK(cv))
4272 cv_ckproto(cv, gv, ps);
4273 /* already defined (or promised)? */
4274 if (exists || GvASSUMECV(gv)) {
4275 if (!block && !attrs) {
4276 if (CvFLAGS(PL_compcv)) {
4277 /* might have had built-in attrs applied */
4278 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4280 /* just a "sub foo;" when &foo is already defined */
4281 SAVEFREESV(PL_compcv);
4284 /* ahem, death to those who redefine active sort subs */
4285 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4286 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4288 if (ckWARN(WARN_REDEFINE)
4290 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4292 line_t oldline = CopLINE(PL_curcop);
4293 if (PL_copline != NOLINE)
4294 CopLINE_set(PL_curcop, PL_copline);
4295 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4296 CvCONST(cv) ? "Constant subroutine %s redefined"
4297 : "Subroutine %s redefined", name);
4298 CopLINE_set(PL_curcop, oldline);
4306 (void)SvREFCNT_inc(const_sv);
4308 assert(!CvROOT(cv) && !CvCONST(cv));
4309 sv_setpv((SV*)cv, ""); /* prototype is "" */
4310 CvXSUBANY(cv).any_ptr = const_sv;
4311 CvXSUB(cv) = const_sv_xsub;
4316 cv = newCONSTSUB(NULL, name, const_sv);
4319 SvREFCNT_dec(PL_compcv);
4321 PL_sub_generation++;
4328 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4329 * before we clobber PL_compcv.
4333 /* Might have had built-in attributes applied -- propagate them. */
4334 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4335 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4336 stash = GvSTASH(CvGV(cv));
4337 else if (CvSTASH(cv))
4338 stash = CvSTASH(cv);
4340 stash = PL_curstash;
4343 /* possibly about to re-define existing subr -- ignore old cv */
4344 rcv = (SV*)PL_compcv;
4345 if (name && GvSTASH(gv))
4346 stash = GvSTASH(gv);
4348 stash = PL_curstash;
4350 apply_attrs(stash, rcv, attrs, FALSE);
4352 if (cv) { /* must reuse cv if autoloaded */
4354 /* got here with just attrs -- work done, so bug out */
4355 SAVEFREESV(PL_compcv);
4358 /* transfer PL_compcv to cv */
4360 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4361 if (!CvWEAKOUTSIDE(cv))
4362 SvREFCNT_dec(CvOUTSIDE(cv));
4363 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4364 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4365 CvOUTSIDE(PL_compcv) = 0;
4366 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4367 CvPADLIST(PL_compcv) = 0;
4368 /* inner references to PL_compcv must be fixed up ... */
4369 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4370 /* ... before we throw it away */
4371 SvREFCNT_dec(PL_compcv);
4373 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4374 ++PL_sub_generation;
4381 PL_sub_generation++;
4385 CvFILE_set_from_cop(cv, PL_curcop);
4386 CvSTASH(cv) = PL_curstash;
4389 sv_setpv((SV*)cv, ps);
4391 if (PL_error_count) {
4395 char *s = strrchr(name, ':');
4397 if (strEQ(s, "BEGIN")) {
4398 const char not_safe[] =
4399 "BEGIN not safe after errors--compilation aborted";
4400 if (PL_in_eval & EVAL_KEEPERR)
4401 Perl_croak(aTHX_ not_safe);
4403 /* force display of errors found but not reported */
4404 sv_catpv(ERRSV, not_safe);
4405 Perl_croak(aTHX_ "%"SVf, ERRSV);
4414 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4415 mod(scalarseq(block), OP_LEAVESUBLV));
4418 /* This makes sub {}; work as expected. */
4419 if (block->op_type == OP_STUB) {
4421 block = newSTATEOP(0, Nullch, 0);
4423 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4425 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4426 OpREFCNT_set(CvROOT(cv), 1);
4427 CvSTART(cv) = LINKLIST(CvROOT(cv));
4428 CvROOT(cv)->op_next = 0;
4429 CALL_PEEP(CvSTART(cv));
4431 /* now that optimizer has done its work, adjust pad values */
4433 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4436 assert(!CvCONST(cv));
4437 if (ps && !*ps && op_const_sv(block, cv))
4441 if (name || aname) {
4443 char *tname = (name ? name : aname);
4445 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4446 SV *sv = NEWSV(0,0);
4447 SV *tmpstr = sv_newmortal();
4448 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4452 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4454 (long)PL_subline, (long)CopLINE(PL_curcop));
4455 gv_efullname3(tmpstr, gv, Nullch);
4456 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4457 hv = GvHVn(db_postponed);
4458 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4459 && (pcv = GvCV(db_postponed)))
4465 call_sv((SV*)pcv, G_DISCARD);
4469 if ((s = strrchr(tname,':')))
4474 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4477 if (strEQ(s, "BEGIN") && !PL_error_count) {
4478 I32 oldscope = PL_scopestack_ix;
4480 SAVECOPFILE(&PL_compiling);
4481 SAVECOPLINE(&PL_compiling);
4484 PL_beginav = newAV();
4485 DEBUG_x( dump_sub(gv) );
4486 av_push(PL_beginav, (SV*)cv);
4487 GvCV(gv) = 0; /* cv has been hijacked */
4488 call_list(oldscope, PL_beginav);
4490 PL_curcop = &PL_compiling;
4491 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4494 else if (strEQ(s, "END") && !PL_error_count) {
4497 DEBUG_x( dump_sub(gv) );
4498 av_unshift(PL_endav, 1);
4499 av_store(PL_endav, 0, (SV*)cv);
4500 GvCV(gv) = 0; /* cv has been hijacked */
4502 else if (strEQ(s, "CHECK") && !PL_error_count) {
4504 PL_checkav = newAV();
4505 DEBUG_x( dump_sub(gv) );
4506 if (PL_main_start && ckWARN(WARN_VOID))
4507 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4508 av_unshift(PL_checkav, 1);
4509 av_store(PL_checkav, 0, (SV*)cv);
4510 GvCV(gv) = 0; /* cv has been hijacked */
4512 else if (strEQ(s, "INIT") && !PL_error_count) {
4514 PL_initav = newAV();
4515 DEBUG_x( dump_sub(gv) );
4516 if (PL_main_start && ckWARN(WARN_VOID))
4517 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4518 av_push(PL_initav, (SV*)cv);
4519 GvCV(gv) = 0; /* cv has been hijacked */
4524 PL_copline = NOLINE;
4529 /* XXX unsafe for threads if eval_owner isn't held */
4531 =for apidoc newCONSTSUB
4533 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4534 eligible for inlining at compile-time.
4540 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4546 SAVECOPLINE(PL_curcop);
4547 CopLINE_set(PL_curcop, PL_copline);
4550 PL_hints &= ~HINT_BLOCK_SCOPE;
4553 SAVESPTR(PL_curstash);
4554 SAVECOPSTASH(PL_curcop);
4555 PL_curstash = stash;
4556 CopSTASH_set(PL_curcop,stash);
4559 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4560 CvXSUBANY(cv).any_ptr = sv;
4562 sv_setpv((SV*)cv, ""); /* prototype is "" */
4565 CopSTASH_free(PL_curcop);
4573 =for apidoc U||newXS
4575 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4581 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4583 GV *gv = gv_fetchpv(name ? name :
4584 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4585 GV_ADDMULTI, SVt_PVCV);
4589 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4591 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4593 /* just a cached method */
4597 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4598 /* already defined (or promised) */
4599 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4600 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4601 line_t oldline = CopLINE(PL_curcop);
4602 if (PL_copline != NOLINE)
4603 CopLINE_set(PL_curcop, PL_copline);
4604 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4605 CvCONST(cv) ? "Constant subroutine %s redefined"
4606 : "Subroutine %s redefined"
4608 CopLINE_set(PL_curcop, oldline);
4615 if (cv) /* must reuse cv if autoloaded */
4618 cv = (CV*)NEWSV(1105,0);
4619 sv_upgrade((SV *)cv, SVt_PVCV);
4623 PL_sub_generation++;
4627 (void)gv_fetchfile(filename);
4628 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4629 an external constant string */
4630 CvXSUB(cv) = subaddr;
4633 const char *s = strrchr(name,':');
4639 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4642 if (strEQ(s, "BEGIN")) {
4644 PL_beginav = newAV();
4645 av_push(PL_beginav, (SV*)cv);
4646 GvCV(gv) = 0; /* cv has been hijacked */
4648 else if (strEQ(s, "END")) {
4651 av_unshift(PL_endav, 1);
4652 av_store(PL_endav, 0, (SV*)cv);
4653 GvCV(gv) = 0; /* cv has been hijacked */
4655 else if (strEQ(s, "CHECK")) {
4657 PL_checkav = newAV();
4658 if (PL_main_start && ckWARN(WARN_VOID))
4659 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4660 av_unshift(PL_checkav, 1);
4661 av_store(PL_checkav, 0, (SV*)cv);
4662 GvCV(gv) = 0; /* cv has been hijacked */
4664 else if (strEQ(s, "INIT")) {
4666 PL_initav = newAV();
4667 if (PL_main_start && ckWARN(WARN_VOID))
4668 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4669 av_push(PL_initav, (SV*)cv);
4670 GvCV(gv) = 0; /* cv has been hijacked */
4681 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4687 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4689 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4691 #ifdef GV_UNIQUE_CHECK
4693 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4697 if ((cv = GvFORM(gv))) {
4698 if (ckWARN(WARN_REDEFINE)) {
4699 line_t oldline = CopLINE(PL_curcop);
4700 if (PL_copline != NOLINE)
4701 CopLINE_set(PL_curcop, PL_copline);
4702 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4703 o ? "Format %"SVf" redefined"
4704 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4705 CopLINE_set(PL_curcop, oldline);
4712 CvFILE_set_from_cop(cv, PL_curcop);
4715 pad_tidy(padtidy_FORMAT);
4716 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4717 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4718 OpREFCNT_set(CvROOT(cv), 1);
4719 CvSTART(cv) = LINKLIST(CvROOT(cv));
4720 CvROOT(cv)->op_next = 0;
4721 CALL_PEEP(CvSTART(cv));
4723 PL_copline = NOLINE;
4728 Perl_newANONLIST(pTHX_ OP *o)
4730 return newUNOP(OP_REFGEN, 0,
4731 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4735 Perl_newANONHASH(pTHX_ OP *o)
4737 return newUNOP(OP_REFGEN, 0,
4738 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4742 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4744 return newANONATTRSUB(floor, proto, Nullop, block);
4748 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4750 return newUNOP(OP_REFGEN, 0,
4751 newSVOP(OP_ANONCODE, 0,
4752 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4756 Perl_oopsAV(pTHX_ OP *o)
4758 switch (o->op_type) {
4760 o->op_type = OP_PADAV;
4761 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4762 return ref(o, OP_RV2AV);
4765 o->op_type = OP_RV2AV;
4766 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4771 if (ckWARN_d(WARN_INTERNAL))
4772 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4779 Perl_oopsHV(pTHX_ OP *o)
4781 switch (o->op_type) {
4784 o->op_type = OP_PADHV;
4785 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4786 return ref(o, OP_RV2HV);
4790 o->op_type = OP_RV2HV;
4791 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4796 if (ckWARN_d(WARN_INTERNAL))
4797 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4804 Perl_newAVREF(pTHX_ OP *o)
4806 if (o->op_type == OP_PADANY) {
4807 o->op_type = OP_PADAV;
4808 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4811 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4812 && ckWARN(WARN_DEPRECATED)) {
4813 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4814 "Using an array as a reference is deprecated");
4816 return newUNOP(OP_RV2AV, 0, scalar(o));
4820 Perl_newGVREF(pTHX_ I32 type, OP *o)
4822 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4823 return newUNOP(OP_NULL, 0, o);
4824 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4828 Perl_newHVREF(pTHX_ OP *o)
4830 if (o->op_type == OP_PADANY) {
4831 o->op_type = OP_PADHV;
4832 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4835 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4836 && ckWARN(WARN_DEPRECATED)) {
4837 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4838 "Using a hash as a reference is deprecated");
4840 return newUNOP(OP_RV2HV, 0, scalar(o));
4844 Perl_oopsCV(pTHX_ OP *o)
4846 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4852 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4854 return newUNOP(OP_RV2CV, flags, scalar(o));
4858 Perl_newSVREF(pTHX_ OP *o)
4860 if (o->op_type == OP_PADANY) {
4861 o->op_type = OP_PADSV;
4862 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4865 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4866 o->op_flags |= OPpDONE_SVREF;
4869 return newUNOP(OP_RV2SV, 0, scalar(o));
4872 /* Check routines. See the comments at the top of this file for details
4873 * on when these are called */
4876 Perl_ck_anoncode(pTHX_ OP *o)
4878 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4879 cSVOPo->op_sv = Nullsv;
4884 Perl_ck_bitop(pTHX_ OP *o)
4886 #define OP_IS_NUMCOMPARE(op) \
4887 ((op) == OP_LT || (op) == OP_I_LT || \
4888 (op) == OP_GT || (op) == OP_I_GT || \
4889 (op) == OP_LE || (op) == OP_I_LE || \
4890 (op) == OP_GE || (op) == OP_I_GE || \
4891 (op) == OP_EQ || (op) == OP_I_EQ || \
4892 (op) == OP_NE || (op) == OP_I_NE || \
4893 (op) == OP_NCMP || (op) == OP_I_NCMP)
4894 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4895 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4896 && (o->op_type == OP_BIT_OR
4897 || o->op_type == OP_BIT_AND
4898 || o->op_type == OP_BIT_XOR))
4900 OP * left = cBINOPo->op_first;
4901 OP * right = left->op_sibling;
4902 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4903 (left->op_flags & OPf_PARENS) == 0) ||
4904 (OP_IS_NUMCOMPARE(right->op_type) &&
4905 (right->op_flags & OPf_PARENS) == 0))
4906 if (ckWARN(WARN_PRECEDENCE))
4907 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4908 "Possible precedence problem on bitwise %c operator",
4909 o->op_type == OP_BIT_OR ? '|'
4910 : o->op_type == OP_BIT_AND ? '&' : '^'
4917 Perl_ck_concat(pTHX_ OP *o)
4919 OP *kid = cUNOPo->op_first;
4920 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4921 !(kUNOP->op_first->op_flags & OPf_MOD))
4922 o->op_flags |= OPf_STACKED;
4927 Perl_ck_spair(pTHX_ OP *o)
4929 if (o->op_flags & OPf_KIDS) {
4932 OPCODE type = o->op_type;
4933 o = modkids(ck_fun(o), type);
4934 kid = cUNOPo->op_first;
4935 newop = kUNOP->op_first->op_sibling;
4937 (newop->op_sibling ||
4938 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4939 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4940 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4944 op_free(kUNOP->op_first);
4945 kUNOP->op_first = newop;
4947 o->op_ppaddr = PL_ppaddr[++o->op_type];
4952 Perl_ck_delete(pTHX_ OP *o)
4956 if (o->op_flags & OPf_KIDS) {
4957 OP *kid = cUNOPo->op_first;
4958 switch (kid->op_type) {
4960 o->op_flags |= OPf_SPECIAL;
4963 o->op_private |= OPpSLICE;
4966 o->op_flags |= OPf_SPECIAL;
4971 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4980 Perl_ck_die(pTHX_ OP *o)
4983 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4989 Perl_ck_eof(pTHX_ OP *o)
4991 I32 type = o->op_type;
4993 if (o->op_flags & OPf_KIDS) {
4994 if (cLISTOPo->op_first->op_type == OP_STUB) {
4996 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5004 Perl_ck_eval(pTHX_ OP *o)
5006 PL_hints |= HINT_BLOCK_SCOPE;
5007 if (o->op_flags & OPf_KIDS) {
5008 SVOP *kid = (SVOP*)cUNOPo->op_first;
5011 o->op_flags &= ~OPf_KIDS;
5014 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5017 cUNOPo->op_first = 0;
5020 NewOp(1101, enter, 1, LOGOP);
5021 enter->op_type = OP_ENTERTRY;
5022 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5023 enter->op_private = 0;
5025 /* establish postfix order */
5026 enter->op_next = (OP*)enter;
5028 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5029 o->op_type = OP_LEAVETRY;
5030 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5031 enter->op_other = o;
5041 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5043 o->op_targ = (PADOFFSET)PL_hints;
5048 Perl_ck_exit(pTHX_ OP *o)
5051 HV *table = GvHV(PL_hintgv);
5053 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5054 if (svp && *svp && SvTRUE(*svp))
5055 o->op_private |= OPpEXIT_VMSISH;
5057 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5063 Perl_ck_exec(pTHX_ OP *o)
5066 if (o->op_flags & OPf_STACKED) {
5068 kid = cUNOPo->op_first->op_sibling;
5069 if (kid->op_type == OP_RV2GV)
5078 Perl_ck_exists(pTHX_ OP *o)
5081 if (o->op_flags & OPf_KIDS) {
5082 OP *kid = cUNOPo->op_first;
5083 if (kid->op_type == OP_ENTERSUB) {
5084 (void) ref(kid, o->op_type);
5085 if (kid->op_type != OP_RV2CV && !PL_error_count)
5086 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5088 o->op_private |= OPpEXISTS_SUB;
5090 else if (kid->op_type == OP_AELEM)
5091 o->op_flags |= OPf_SPECIAL;
5092 else if (kid->op_type != OP_HELEM)
5093 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5102 Perl_ck_gvconst(pTHX_ register OP *o)
5104 o = fold_constants(o);
5105 if (o->op_type == OP_CONST)
5112 Perl_ck_rvconst(pTHX_ register OP *o)
5114 SVOP *kid = (SVOP*)cUNOPo->op_first;
5116 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5117 if (kid->op_type == OP_CONST) {
5120 SV *kidsv = kid->op_sv;
5122 /* Is it a constant from cv_const_sv()? */
5123 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5124 SV *rsv = SvRV(kidsv);
5125 int svtype = SvTYPE(rsv);
5126 const char *badtype = Nullch;
5128 switch (o->op_type) {
5130 if (svtype > SVt_PVMG)
5131 badtype = "a SCALAR";
5134 if (svtype != SVt_PVAV)
5135 badtype = "an ARRAY";
5138 if (svtype != SVt_PVHV)
5142 if (svtype != SVt_PVCV)
5147 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5150 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5151 const char *badthing = Nullch;
5152 switch (o->op_type) {
5154 badthing = "a SCALAR";
5157 badthing = "an ARRAY";
5160 badthing = "a HASH";
5165 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5169 * This is a little tricky. We only want to add the symbol if we
5170 * didn't add it in the lexer. Otherwise we get duplicate strict
5171 * warnings. But if we didn't add it in the lexer, we must at
5172 * least pretend like we wanted to add it even if it existed before,
5173 * or we get possible typo warnings. OPpCONST_ENTERED says
5174 * whether the lexer already added THIS instance of this symbol.
5176 iscv = (o->op_type == OP_RV2CV) * 2;
5178 gv = gv_fetchsv(kidsv,
5179 iscv | !(kid->op_private & OPpCONST_ENTERED),
5182 : o->op_type == OP_RV2SV
5184 : o->op_type == OP_RV2AV
5186 : o->op_type == OP_RV2HV
5189 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5191 kid->op_type = OP_GV;
5192 SvREFCNT_dec(kid->op_sv);
5194 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5195 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5196 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5198 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5200 kid->op_sv = SvREFCNT_inc(gv);
5202 kid->op_private = 0;
5203 kid->op_ppaddr = PL_ppaddr[OP_GV];
5210 Perl_ck_ftst(pTHX_ OP *o)
5212 I32 type = o->op_type;
5214 if (o->op_flags & OPf_REF) {
5217 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5218 SVOP *kid = (SVOP*)cUNOPo->op_first;
5220 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5221 OP *newop = newGVOP(type, OPf_REF,
5222 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5228 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5229 OP_IS_FILETEST_ACCESS(o))
5230 o->op_private |= OPpFT_ACCESS;
5232 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5233 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5234 o->op_private |= OPpFT_STACKED;
5238 if (type == OP_FTTTY)
5239 o = newGVOP(type, OPf_REF, PL_stdingv);
5241 o = newUNOP(type, 0, newDEFSVOP());
5247 Perl_ck_fun(pTHX_ OP *o)
5253 int type = o->op_type;
5254 register I32 oa = PL_opargs[type] >> OASHIFT;
5256 if (o->op_flags & OPf_STACKED) {
5257 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5260 return no_fh_allowed(o);
5263 if (o->op_flags & OPf_KIDS) {
5264 tokid = &cLISTOPo->op_first;
5265 kid = cLISTOPo->op_first;
5266 if (kid->op_type == OP_PUSHMARK ||
5267 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5269 tokid = &kid->op_sibling;
5270 kid = kid->op_sibling;
5272 if (!kid && PL_opargs[type] & OA_DEFGV)
5273 *tokid = kid = newDEFSVOP();
5277 sibl = kid->op_sibling;
5280 /* list seen where single (scalar) arg expected? */
5281 if (numargs == 1 && !(oa >> 4)
5282 && kid->op_type == OP_LIST && type != OP_SCALAR)
5284 return too_many_arguments(o,PL_op_desc[type]);
5297 if ((type == OP_PUSH || type == OP_UNSHIFT)
5298 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5299 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5300 "Useless use of %s with no values",
5303 if (kid->op_type == OP_CONST &&
5304 (kid->op_private & OPpCONST_BARE))
5306 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5307 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5308 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5309 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5310 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5311 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5314 kid->op_sibling = sibl;
5317 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5318 bad_type(numargs, "array", PL_op_desc[type], kid);
5322 if (kid->op_type == OP_CONST &&
5323 (kid->op_private & OPpCONST_BARE))
5325 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5326 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5327 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5328 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5329 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5330 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5333 kid->op_sibling = sibl;
5336 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5337 bad_type(numargs, "hash", PL_op_desc[type], kid);
5342 OP *newop = newUNOP(OP_NULL, 0, kid);
5343 kid->op_sibling = 0;
5345 newop->op_next = newop;
5347 kid->op_sibling = sibl;
5352 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5353 if (kid->op_type == OP_CONST &&
5354 (kid->op_private & OPpCONST_BARE))
5356 OP *newop = newGVOP(OP_GV, 0,
5357 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5358 if (!(o->op_private & 1) && /* if not unop */
5359 kid == cLISTOPo->op_last)
5360 cLISTOPo->op_last = newop;
5364 else if (kid->op_type == OP_READLINE) {
5365 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5366 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5369 I32 flags = OPf_SPECIAL;
5373 /* is this op a FH constructor? */
5374 if (is_handle_constructor(o,numargs)) {
5375 const char *name = Nullch;
5379 /* Set a flag to tell rv2gv to vivify
5380 * need to "prove" flag does not mean something
5381 * else already - NI-S 1999/05/07
5384 if (kid->op_type == OP_PADSV) {
5385 name = PAD_COMPNAME_PV(kid->op_targ);
5386 /* SvCUR of a pad namesv can't be trusted
5387 * (see PL_generation), so calc its length
5393 else if (kid->op_type == OP_RV2SV
5394 && kUNOP->op_first->op_type == OP_GV)
5396 GV *gv = cGVOPx_gv(kUNOP->op_first);
5398 len = GvNAMELEN(gv);
5400 else if (kid->op_type == OP_AELEM
5401 || kid->op_type == OP_HELEM)
5406 if ((op = ((BINOP*)kid)->op_first)) {
5407 SV *tmpstr = Nullsv;
5409 kid->op_type == OP_AELEM ?
5411 if (((op->op_type == OP_RV2AV) ||
5412 (op->op_type == OP_RV2HV)) &&
5413 (op = ((UNOP*)op)->op_first) &&
5414 (op->op_type == OP_GV)) {
5415 /* packagevar $a[] or $h{} */
5416 GV *gv = cGVOPx_gv(op);
5424 else if (op->op_type == OP_PADAV
5425 || op->op_type == OP_PADHV) {
5426 /* lexicalvar $a[] or $h{} */
5428 PAD_COMPNAME_PV(op->op_targ);
5438 name = SvPV(tmpstr, len);
5443 name = "__ANONIO__";
5450 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5451 namesv = PAD_SVl(targ);
5452 (void)SvUPGRADE(namesv, SVt_PV);
5454 sv_setpvn(namesv, "$", 1);
5455 sv_catpvn(namesv, name, len);
5458 kid->op_sibling = 0;
5459 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5460 kid->op_targ = targ;
5461 kid->op_private |= priv;
5463 kid->op_sibling = sibl;
5469 mod(scalar(kid), type);
5473 tokid = &kid->op_sibling;
5474 kid = kid->op_sibling;
5476 o->op_private |= numargs;
5478 return too_many_arguments(o,OP_DESC(o));
5481 else if (PL_opargs[type] & OA_DEFGV) {
5483 return newUNOP(type, 0, newDEFSVOP());
5487 while (oa & OA_OPTIONAL)
5489 if (oa && oa != OA_LIST)
5490 return too_few_arguments(o,OP_DESC(o));
5496 Perl_ck_glob(pTHX_ OP *o)
5501 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5502 append_elem(OP_GLOB, o, newDEFSVOP());
5504 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5505 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5507 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5510 #if !defined(PERL_EXTERNAL_GLOB)
5511 /* XXX this can be tightened up and made more failsafe. */
5512 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5515 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5516 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5517 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5518 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5519 GvCV(gv) = GvCV(glob_gv);
5520 (void)SvREFCNT_inc((SV*)GvCV(gv));
5521 GvIMPORTED_CV_on(gv);
5524 #endif /* PERL_EXTERNAL_GLOB */
5526 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5527 append_elem(OP_GLOB, o,
5528 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5529 o->op_type = OP_LIST;
5530 o->op_ppaddr = PL_ppaddr[OP_LIST];
5531 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5532 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5533 cLISTOPo->op_first->op_targ = 0;
5534 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5535 append_elem(OP_LIST, o,
5536 scalar(newUNOP(OP_RV2CV, 0,
5537 newGVOP(OP_GV, 0, gv)))));
5538 o = newUNOP(OP_NULL, 0, ck_subr(o));
5539 o->op_targ = OP_GLOB; /* hint at what it used to be */
5542 gv = newGVgen("main");
5544 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5550 Perl_ck_grep(pTHX_ OP *o)
5554 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5557 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5558 NewOp(1101, gwop, 1, LOGOP);
5560 if (o->op_flags & OPf_STACKED) {
5563 kid = cLISTOPo->op_first->op_sibling;
5564 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5567 kid->op_next = (OP*)gwop;
5568 o->op_flags &= ~OPf_STACKED;
5570 kid = cLISTOPo->op_first->op_sibling;
5571 if (type == OP_MAPWHILE)
5578 kid = cLISTOPo->op_first->op_sibling;
5579 if (kid->op_type != OP_NULL)
5580 Perl_croak(aTHX_ "panic: ck_grep");
5581 kid = kUNOP->op_first;
5583 gwop->op_type = type;
5584 gwop->op_ppaddr = PL_ppaddr[type];
5585 gwop->op_first = listkids(o);
5586 gwop->op_flags |= OPf_KIDS;
5587 gwop->op_other = LINKLIST(kid);
5588 kid->op_next = (OP*)gwop;
5589 offset = pad_findmy("$_");
5590 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5591 o->op_private = gwop->op_private = 0;
5592 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5595 o->op_private = gwop->op_private = OPpGREP_LEX;
5596 gwop->op_targ = o->op_targ = offset;
5599 kid = cLISTOPo->op_first->op_sibling;
5600 if (!kid || !kid->op_sibling)
5601 return too_few_arguments(o,OP_DESC(o));
5602 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5603 mod(kid, OP_GREPSTART);
5609 Perl_ck_index(pTHX_ OP *o)
5611 if (o->op_flags & OPf_KIDS) {
5612 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5614 kid = kid->op_sibling; /* get past "big" */
5615 if (kid && kid->op_type == OP_CONST)
5616 fbm_compile(((SVOP*)kid)->op_sv, 0);
5622 Perl_ck_lengthconst(pTHX_ OP *o)
5624 /* XXX length optimization goes here */
5629 Perl_ck_lfun(pTHX_ OP *o)
5631 OPCODE type = o->op_type;
5632 return modkids(ck_fun(o), type);
5636 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5638 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5639 switch (cUNOPo->op_first->op_type) {
5641 /* This is needed for
5642 if (defined %stash::)
5643 to work. Do not break Tk.
5645 break; /* Globals via GV can be undef */
5647 case OP_AASSIGN: /* Is this a good idea? */
5648 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5649 "defined(@array) is deprecated");
5650 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5651 "\t(Maybe you should just omit the defined()?)\n");
5654 /* This is needed for
5655 if (defined %stash::)
5656 to work. Do not break Tk.
5658 break; /* Globals via GV can be undef */
5660 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5661 "defined(%%hash) is deprecated");
5662 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5663 "\t(Maybe you should just omit the defined()?)\n");
5674 Perl_ck_rfun(pTHX_ OP *o)
5676 OPCODE type = o->op_type;
5677 return refkids(ck_fun(o), type);
5681 Perl_ck_listiob(pTHX_ OP *o)
5685 kid = cLISTOPo->op_first;
5688 kid = cLISTOPo->op_first;
5690 if (kid->op_type == OP_PUSHMARK)
5691 kid = kid->op_sibling;
5692 if (kid && o->op_flags & OPf_STACKED)
5693 kid = kid->op_sibling;
5694 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5695 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5696 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5697 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5698 cLISTOPo->op_first->op_sibling = kid;
5699 cLISTOPo->op_last = kid;
5700 kid = kid->op_sibling;
5705 append_elem(o->op_type, o, newDEFSVOP());
5711 Perl_ck_sassign(pTHX_ OP *o)
5713 OP *kid = cLISTOPo->op_first;
5714 /* has a disposable target? */
5715 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5716 && !(kid->op_flags & OPf_STACKED)
5717 /* Cannot steal the second time! */
5718 && !(kid->op_private & OPpTARGET_MY))
5720 OP *kkid = kid->op_sibling;
5722 /* Can just relocate the target. */
5723 if (kkid && kkid->op_type == OP_PADSV
5724 && !(kkid->op_private & OPpLVAL_INTRO))
5726 kid->op_targ = kkid->op_targ;
5728 /* Now we do not need PADSV and SASSIGN. */
5729 kid->op_sibling = o->op_sibling; /* NULL */
5730 cLISTOPo->op_first = NULL;
5733 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5737 /* optimise C<my $x = undef> to C<my $x> */
5738 if (kid->op_type == OP_UNDEF) {
5739 OP *kkid = kid->op_sibling;
5740 if (kkid && kkid->op_type == OP_PADSV
5741 && (kkid->op_private & OPpLVAL_INTRO))
5743 cLISTOPo->op_first = NULL;
5744 kid->op_sibling = NULL;
5754 Perl_ck_match(pTHX_ OP *o)
5756 if (o->op_type != OP_QR) {
5757 I32 offset = pad_findmy("$_");
5758 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5759 o->op_targ = offset;
5760 o->op_private |= OPpTARGET_MY;
5763 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5764 o->op_private |= OPpRUNTIME;
5769 Perl_ck_method(pTHX_ OP *o)
5771 OP *kid = cUNOPo->op_first;
5772 if (kid->op_type == OP_CONST) {
5773 SV* sv = kSVOP->op_sv;
5774 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5776 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5777 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5780 kSVOP->op_sv = Nullsv;
5782 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5791 Perl_ck_null(pTHX_ OP *o)
5797 Perl_ck_open(pTHX_ OP *o)
5799 HV *table = GvHV(PL_hintgv);
5803 svp = hv_fetch(table, "open_IN", 7, FALSE);
5805 mode = mode_from_discipline(*svp);
5806 if (mode & O_BINARY)
5807 o->op_private |= OPpOPEN_IN_RAW;
5808 else if (mode & O_TEXT)
5809 o->op_private |= OPpOPEN_IN_CRLF;
5812 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5814 mode = mode_from_discipline(*svp);
5815 if (mode & O_BINARY)
5816 o->op_private |= OPpOPEN_OUT_RAW;
5817 else if (mode & O_TEXT)
5818 o->op_private |= OPpOPEN_OUT_CRLF;
5821 if (o->op_type == OP_BACKTICK)
5824 /* In case of three-arg dup open remove strictness
5825 * from the last arg if it is a bareword. */
5826 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5827 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5831 if ((last->op_type == OP_CONST) && /* The bareword. */
5832 (last->op_private & OPpCONST_BARE) &&
5833 (last->op_private & OPpCONST_STRICT) &&
5834 (oa = first->op_sibling) && /* The fh. */
5835 (oa = oa->op_sibling) && /* The mode. */
5836 SvPOK(((SVOP*)oa)->op_sv) &&
5837 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5838 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5839 (last == oa->op_sibling)) /* The bareword. */
5840 last->op_private &= ~OPpCONST_STRICT;
5846 Perl_ck_repeat(pTHX_ OP *o)
5848 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5849 o->op_private |= OPpREPEAT_DOLIST;
5850 cBINOPo->op_first = force_list(cBINOPo->op_first);
5858 Perl_ck_require(pTHX_ OP *o)
5862 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5863 SVOP *kid = (SVOP*)cUNOPo->op_first;
5865 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5867 for (s = SvPVX(kid->op_sv); *s; s++) {
5868 if (*s == ':' && s[1] == ':') {
5870 Move(s+2, s+1, strlen(s+2)+1, char);
5871 --SvCUR(kid->op_sv);
5874 if (SvREADONLY(kid->op_sv)) {
5875 SvREADONLY_off(kid->op_sv);
5876 sv_catpvn(kid->op_sv, ".pm", 3);
5877 SvREADONLY_on(kid->op_sv);
5880 sv_catpvn(kid->op_sv, ".pm", 3);
5884 /* handle override, if any */
5885 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5886 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5887 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5889 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5890 OP *kid = cUNOPo->op_first;
5891 cUNOPo->op_first = 0;
5893 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5894 append_elem(OP_LIST, kid,
5895 scalar(newUNOP(OP_RV2CV, 0,
5904 Perl_ck_return(pTHX_ OP *o)
5907 if (CvLVALUE(PL_compcv)) {
5908 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5909 mod(kid, OP_LEAVESUBLV);
5916 Perl_ck_retarget(pTHX_ OP *o)
5918 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5925 Perl_ck_select(pTHX_ OP *o)
5928 if (o->op_flags & OPf_KIDS) {
5929 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5930 if (kid && kid->op_sibling) {
5931 o->op_type = OP_SSELECT;
5932 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5934 return fold_constants(o);
5938 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5939 if (kid && kid->op_type == OP_RV2GV)
5940 kid->op_private &= ~HINT_STRICT_REFS;
5945 Perl_ck_shift(pTHX_ OP *o)
5947 I32 type = o->op_type;
5949 if (!(o->op_flags & OPf_KIDS)) {
5953 argop = newUNOP(OP_RV2AV, 0,
5954 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5955 return newUNOP(type, 0, scalar(argop));
5957 return scalar(modkids(ck_fun(o), type));
5961 Perl_ck_sort(pTHX_ OP *o)
5965 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5967 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5968 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5970 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5972 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5974 if (kid->op_type == OP_SCOPE) {
5978 else if (kid->op_type == OP_LEAVE) {
5979 if (o->op_type == OP_SORT) {
5980 op_null(kid); /* wipe out leave */
5983 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5984 if (k->op_next == kid)
5986 /* don't descend into loops */
5987 else if (k->op_type == OP_ENTERLOOP
5988 || k->op_type == OP_ENTERITER)
5990 k = cLOOPx(k)->op_lastop;
5995 kid->op_next = 0; /* just disconnect the leave */
5996 k = kLISTOP->op_first;
6001 if (o->op_type == OP_SORT) {
6002 /* provide scalar context for comparison function/block */
6008 o->op_flags |= OPf_SPECIAL;
6010 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6013 firstkid = firstkid->op_sibling;
6016 /* provide list context for arguments */
6017 if (o->op_type == OP_SORT)
6024 S_simplify_sort(pTHX_ OP *o)
6026 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6031 if (!(o->op_flags & OPf_STACKED))
6033 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6034 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6035 kid = kUNOP->op_first; /* get past null */
6036 if (kid->op_type != OP_SCOPE)
6038 kid = kLISTOP->op_last; /* get past scope */
6039 switch(kid->op_type) {
6047 k = kid; /* remember this node*/
6048 if (kBINOP->op_first->op_type != OP_RV2SV)
6050 kid = kBINOP->op_first; /* get past cmp */
6051 if (kUNOP->op_first->op_type != OP_GV)
6053 kid = kUNOP->op_first; /* get past rv2sv */
6055 if (GvSTASH(gv) != PL_curstash)
6057 gvname = GvNAME(gv);
6058 if (*gvname == 'a' && gvname[1] == '\0')
6060 else if (*gvname == 'b' && gvname[1] == '\0')
6065 kid = k; /* back to cmp */
6066 if (kBINOP->op_last->op_type != OP_RV2SV)
6068 kid = kBINOP->op_last; /* down to 2nd arg */
6069 if (kUNOP->op_first->op_type != OP_GV)
6071 kid = kUNOP->op_first; /* get past rv2sv */
6073 if (GvSTASH(gv) != PL_curstash)
6075 gvname = GvNAME(gv);
6077 ? !(*gvname == 'a' && gvname[1] == '\0')
6078 : !(*gvname == 'b' && gvname[1] == '\0'))
6080 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6082 o->op_private |= OPpSORT_DESCEND;
6083 if (k->op_type == OP_NCMP)
6084 o->op_private |= OPpSORT_NUMERIC;
6085 if (k->op_type == OP_I_NCMP)
6086 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6087 kid = cLISTOPo->op_first->op_sibling;
6088 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6089 op_free(kid); /* then delete it */
6093 Perl_ck_split(pTHX_ OP *o)
6097 if (o->op_flags & OPf_STACKED)
6098 return no_fh_allowed(o);
6100 kid = cLISTOPo->op_first;
6101 if (kid->op_type != OP_NULL)
6102 Perl_croak(aTHX_ "panic: ck_split");
6103 kid = kid->op_sibling;
6104 op_free(cLISTOPo->op_first);
6105 cLISTOPo->op_first = kid;
6107 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6108 cLISTOPo->op_last = kid; /* There was only one element previously */
6111 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6112 OP *sibl = kid->op_sibling;
6113 kid->op_sibling = 0;
6114 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6115 if (cLISTOPo->op_first == cLISTOPo->op_last)
6116 cLISTOPo->op_last = kid;
6117 cLISTOPo->op_first = kid;
6118 kid->op_sibling = sibl;
6121 kid->op_type = OP_PUSHRE;
6122 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6124 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6125 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6126 "Use of /g modifier is meaningless in split");
6129 if (!kid->op_sibling)
6130 append_elem(OP_SPLIT, o, newDEFSVOP());
6132 kid = kid->op_sibling;
6135 if (!kid->op_sibling)
6136 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6138 kid = kid->op_sibling;
6141 if (kid->op_sibling)
6142 return too_many_arguments(o,OP_DESC(o));
6148 Perl_ck_join(pTHX_ OP *o)
6150 if (ckWARN(WARN_SYNTAX)) {
6151 OP *kid = cLISTOPo->op_first->op_sibling;
6152 if (kid && kid->op_type == OP_MATCH) {
6153 const char *pmstr = "STRING";
6154 if (PM_GETRE(kPMOP))
6155 pmstr = PM_GETRE(kPMOP)->precomp;
6156 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6157 "/%s/ should probably be written as \"%s\"",
6165 Perl_ck_subr(pTHX_ OP *o)
6167 OP *prev = ((cUNOPo->op_first->op_sibling)
6168 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6169 OP *o2 = prev->op_sibling;
6176 I32 contextclass = 0;
6181 o->op_private |= OPpENTERSUB_HASTARG;
6182 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6183 if (cvop->op_type == OP_RV2CV) {
6185 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6186 op_null(cvop); /* disable rv2cv */
6187 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6188 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6189 GV *gv = cGVOPx_gv(tmpop);
6192 tmpop->op_private |= OPpEARLY_CV;
6195 namegv = CvANON(cv) ? gv : CvGV(cv);
6196 proto = SvPV((SV*)cv, n_a);
6198 if (CvASSERTION(cv)) {
6199 if (PL_hints & HINT_ASSERTING) {
6200 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6201 o->op_private |= OPpENTERSUB_DB;
6205 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6206 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6207 "Impossible to activate assertion call");
6214 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6215 if (o2->op_type == OP_CONST)
6216 o2->op_private &= ~OPpCONST_STRICT;
6217 else if (o2->op_type == OP_LIST) {
6218 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6219 if (o && o->op_type == OP_CONST)
6220 o->op_private &= ~OPpCONST_STRICT;
6223 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6224 if (PERLDB_SUB && PL_curstash != PL_debstash)
6225 o->op_private |= OPpENTERSUB_DB;
6226 while (o2 != cvop) {
6230 return too_many_arguments(o, gv_ename(namegv));
6248 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6250 arg == 1 ? "block or sub {}" : "sub {}",
6251 gv_ename(namegv), o2);
6254 /* '*' allows any scalar type, including bareword */
6257 if (o2->op_type == OP_RV2GV)
6258 goto wrapref; /* autoconvert GLOB -> GLOBref */
6259 else if (o2->op_type == OP_CONST)
6260 o2->op_private &= ~OPpCONST_STRICT;
6261 else if (o2->op_type == OP_ENTERSUB) {
6262 /* accidental subroutine, revert to bareword */
6263 OP *gvop = ((UNOP*)o2)->op_first;
6264 if (gvop && gvop->op_type == OP_NULL) {
6265 gvop = ((UNOP*)gvop)->op_first;
6267 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6270 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6271 (gvop = ((UNOP*)gvop)->op_first) &&
6272 gvop->op_type == OP_GV)
6274 GV *gv = cGVOPx_gv(gvop);
6275 OP *sibling = o2->op_sibling;
6276 SV *n = newSVpvn("",0);
6278 gv_fullname4(n, gv, "", FALSE);
6279 o2 = newSVOP(OP_CONST, 0, n);
6280 prev->op_sibling = o2;
6281 o2->op_sibling = sibling;
6297 if (contextclass++ == 0) {
6298 e = strchr(proto, ']');
6299 if (!e || e == proto)
6312 while (*--p != '[');
6313 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6314 gv_ename(namegv), o2);
6320 if (o2->op_type == OP_RV2GV)
6323 bad_type(arg, "symbol", gv_ename(namegv), o2);
6326 if (o2->op_type == OP_ENTERSUB)
6329 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6332 if (o2->op_type == OP_RV2SV ||
6333 o2->op_type == OP_PADSV ||
6334 o2->op_type == OP_HELEM ||
6335 o2->op_type == OP_AELEM ||
6336 o2->op_type == OP_THREADSV)
6339 bad_type(arg, "scalar", gv_ename(namegv), o2);
6342 if (o2->op_type == OP_RV2AV ||
6343 o2->op_type == OP_PADAV)
6346 bad_type(arg, "array", gv_ename(namegv), o2);
6349 if (o2->op_type == OP_RV2HV ||
6350 o2->op_type == OP_PADHV)
6353 bad_type(arg, "hash", gv_ename(namegv), o2);
6358 OP* sib = kid->op_sibling;
6359 kid->op_sibling = 0;
6360 o2 = newUNOP(OP_REFGEN, 0, kid);
6361 o2->op_sibling = sib;
6362 prev->op_sibling = o2;
6364 if (contextclass && e) {
6379 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6380 gv_ename(namegv), cv);
6385 mod(o2, OP_ENTERSUB);
6387 o2 = o2->op_sibling;
6389 if (proto && !optional &&
6390 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6391 return too_few_arguments(o, gv_ename(namegv));
6394 o=newSVOP(OP_CONST, 0, newSViv(0));
6400 Perl_ck_svconst(pTHX_ OP *o)
6402 SvREADONLY_on(cSVOPo->op_sv);
6407 Perl_ck_trunc(pTHX_ OP *o)
6409 if (o->op_flags & OPf_KIDS) {
6410 SVOP *kid = (SVOP*)cUNOPo->op_first;
6412 if (kid->op_type == OP_NULL)
6413 kid = (SVOP*)kid->op_sibling;
6414 if (kid && kid->op_type == OP_CONST &&
6415 (kid->op_private & OPpCONST_BARE))
6417 o->op_flags |= OPf_SPECIAL;
6418 kid->op_private &= ~OPpCONST_STRICT;
6425 Perl_ck_unpack(pTHX_ OP *o)
6427 OP *kid = cLISTOPo->op_first;
6428 if (kid->op_sibling) {
6429 kid = kid->op_sibling;
6430 if (!kid->op_sibling)
6431 kid->op_sibling = newDEFSVOP();
6437 Perl_ck_substr(pTHX_ OP *o)
6440 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6441 OP *kid = cLISTOPo->op_first;
6443 if (kid->op_type == OP_NULL)
6444 kid = kid->op_sibling;
6446 kid->op_flags |= OPf_MOD;
6452 /* A peephole optimizer. We visit the ops in the order they're to execute.
6453 * See the comments at the top of this file for more details about when
6454 * peep() is called */
6457 Perl_peep(pTHX_ register OP *o)
6459 register OP* oldop = 0;
6461 if (!o || o->op_opt)
6465 SAVEVPTR(PL_curcop);
6466 for (; o; o = o->op_next) {
6470 switch (o->op_type) {
6474 PL_curcop = ((COP*)o); /* for warnings */
6479 if (cSVOPo->op_private & OPpCONST_STRICT)
6480 no_bareword_allowed(o);
6482 case OP_METHOD_NAMED:
6483 /* Relocate sv to the pad for thread safety.
6484 * Despite being a "constant", the SV is written to,
6485 * for reference counts, sv_upgrade() etc. */
6487 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6488 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6489 /* If op_sv is already a PADTMP then it is being used by
6490 * some pad, so make a copy. */
6491 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6492 SvREADONLY_on(PAD_SVl(ix));
6493 SvREFCNT_dec(cSVOPo->op_sv);
6496 SvREFCNT_dec(PAD_SVl(ix));
6497 SvPADTMP_on(cSVOPo->op_sv);
6498 PAD_SETSV(ix, cSVOPo->op_sv);
6499 /* XXX I don't know how this isn't readonly already. */
6500 SvREADONLY_on(PAD_SVl(ix));
6502 cSVOPo->op_sv = Nullsv;
6510 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6511 if (o->op_next->op_private & OPpTARGET_MY) {
6512 if (o->op_flags & OPf_STACKED) /* chained concats */
6513 goto ignore_optimization;
6515 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6516 o->op_targ = o->op_next->op_targ;
6517 o->op_next->op_targ = 0;
6518 o->op_private |= OPpTARGET_MY;
6521 op_null(o->op_next);
6523 ignore_optimization:
6527 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6529 break; /* Scalar stub must produce undef. List stub is noop */
6533 if (o->op_targ == OP_NEXTSTATE
6534 || o->op_targ == OP_DBSTATE
6535 || o->op_targ == OP_SETSTATE)
6537 PL_curcop = ((COP*)o);
6539 /* XXX: We avoid setting op_seq here to prevent later calls
6540 to peep() from mistakenly concluding that optimisation
6541 has already occurred. This doesn't fix the real problem,
6542 though (See 20010220.007). AMS 20010719 */
6543 /* op_seq functionality is now replaced by op_opt */
6544 if (oldop && o->op_next) {
6545 oldop->op_next = o->op_next;
6553 if (oldop && o->op_next) {
6554 oldop->op_next = o->op_next;
6562 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6563 OP* pop = (o->op_type == OP_PADAV) ?
6564 o->op_next : o->op_next->op_next;
6566 if (pop && pop->op_type == OP_CONST &&
6567 ((PL_op = pop->op_next)) &&
6568 pop->op_next->op_type == OP_AELEM &&
6569 !(pop->op_next->op_private &
6570 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6571 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6576 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6577 no_bareword_allowed(pop);
6578 if (o->op_type == OP_GV)
6579 op_null(o->op_next);
6580 op_null(pop->op_next);
6582 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6583 o->op_next = pop->op_next->op_next;
6584 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6585 o->op_private = (U8)i;
6586 if (o->op_type == OP_GV) {
6591 o->op_flags |= OPf_SPECIAL;
6592 o->op_type = OP_AELEMFAST;
6598 if (o->op_next->op_type == OP_RV2SV) {
6599 if (!(o->op_next->op_private & OPpDEREF)) {
6600 op_null(o->op_next);
6601 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6603 o->op_next = o->op_next->op_next;
6604 o->op_type = OP_GVSV;
6605 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6608 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6610 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6611 /* XXX could check prototype here instead of just carping */
6612 SV *sv = sv_newmortal();
6613 gv_efullname3(sv, gv, Nullch);
6614 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6615 "%"SVf"() called too early to check prototype",
6619 else if (o->op_next->op_type == OP_READLINE
6620 && o->op_next->op_next->op_type == OP_CONCAT
6621 && (o->op_next->op_next->op_flags & OPf_STACKED))
6623 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6624 o->op_type = OP_RCATLINE;
6625 o->op_flags |= OPf_STACKED;
6626 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6627 op_null(o->op_next->op_next);
6628 op_null(o->op_next);
6645 while (cLOGOP->op_other->op_type == OP_NULL)
6646 cLOGOP->op_other = cLOGOP->op_other->op_next;
6647 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6653 while (cLOOP->op_redoop->op_type == OP_NULL)
6654 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6655 peep(cLOOP->op_redoop);
6656 while (cLOOP->op_nextop->op_type == OP_NULL)
6657 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6658 peep(cLOOP->op_nextop);
6659 while (cLOOP->op_lastop->op_type == OP_NULL)
6660 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6661 peep(cLOOP->op_lastop);
6668 while (cPMOP->op_pmreplstart &&
6669 cPMOP->op_pmreplstart->op_type == OP_NULL)
6670 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6671 peep(cPMOP->op_pmreplstart);
6676 if (ckWARN(WARN_SYNTAX) && o->op_next
6677 && o->op_next->op_type == OP_NEXTSTATE) {
6678 if (o->op_next->op_sibling &&
6679 o->op_next->op_sibling->op_type != OP_EXIT &&
6680 o->op_next->op_sibling->op_type != OP_WARN &&
6681 o->op_next->op_sibling->op_type != OP_DIE) {
6682 line_t oldline = CopLINE(PL_curcop);
6684 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6685 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6686 "Statement unlikely to be reached");
6687 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6688 "\t(Maybe you meant system() when you said exec()?)\n");
6689 CopLINE_set(PL_curcop, oldline);
6704 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6707 /* Make the CONST have a shared SV */
6708 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6709 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6710 key = SvPV(sv, keylen);
6711 lexname = newSVpvn_share(key,
6712 SvUTF8(sv) ? -(I32)keylen : keylen,
6718 if ((o->op_private & (OPpLVAL_INTRO)))
6721 rop = (UNOP*)((BINOP*)o)->op_first;
6722 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6724 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6725 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6727 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6728 if (!fields || !GvHV(*fields))
6730 key = SvPV(*svp, keylen);
6731 if (!hv_fetch(GvHV(*fields), key,
6732 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6734 Perl_croak(aTHX_ "No such class field \"%s\" "
6735 "in variable %s of type %s",
6736 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6749 SVOP *first_key_op, *key_op;
6751 if ((o->op_private & (OPpLVAL_INTRO))
6752 /* I bet there's always a pushmark... */
6753 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6754 /* hmmm, no optimization if list contains only one key. */
6756 rop = (UNOP*)((LISTOP*)o)->op_last;
6757 if (rop->op_type != OP_RV2HV)
6759 if (rop->op_first->op_type == OP_PADSV)
6760 /* @$hash{qw(keys here)} */
6761 rop = (UNOP*)rop->op_first;
6763 /* @{$hash}{qw(keys here)} */
6764 if (rop->op_first->op_type == OP_SCOPE
6765 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6767 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6773 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6774 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6776 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6777 if (!fields || !GvHV(*fields))
6779 /* Again guessing that the pushmark can be jumped over.... */
6780 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6781 ->op_first->op_sibling;
6782 for (key_op = first_key_op; key_op;
6783 key_op = (SVOP*)key_op->op_sibling) {
6784 if (key_op->op_type != OP_CONST)
6786 svp = cSVOPx_svp(key_op);
6787 key = SvPV(*svp, keylen);
6788 if (!hv_fetch(GvHV(*fields), key,
6789 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6791 Perl_croak(aTHX_ "No such class field \"%s\" "
6792 "in variable %s of type %s",
6793 key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6800 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6804 /* check that RHS of sort is a single plain array */
6805 oright = cUNOPo->op_first;
6806 if (!oright || oright->op_type != OP_PUSHMARK)
6809 /* reverse sort ... can be optimised. */
6810 if (!cUNOPo->op_sibling) {
6811 /* Nothing follows us on the list. */
6812 OP *reverse = o->op_next;
6814 if (reverse->op_type == OP_REVERSE &&
6815 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6816 OP *pushmark = cUNOPx(reverse)->op_first;
6817 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6818 && (cUNOPx(pushmark)->op_sibling == o)) {
6819 /* reverse -> pushmark -> sort */
6820 o->op_private |= OPpSORT_REVERSE;
6822 pushmark->op_next = oright->op_next;
6828 /* make @a = sort @a act in-place */
6832 oright = cUNOPx(oright)->op_sibling;
6835 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6836 oright = cUNOPx(oright)->op_sibling;
6840 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6841 || oright->op_next != o
6842 || (oright->op_private & OPpLVAL_INTRO)
6846 /* o2 follows the chain of op_nexts through the LHS of the
6847 * assign (if any) to the aassign op itself */
6849 if (!o2 || o2->op_type != OP_NULL)
6852 if (!o2 || o2->op_type != OP_PUSHMARK)
6855 if (o2 && o2->op_type == OP_GV)
6858 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6859 || (o2->op_private & OPpLVAL_INTRO)
6864 if (!o2 || o2->op_type != OP_NULL)
6867 if (!o2 || o2->op_type != OP_AASSIGN
6868 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6871 /* check that the sort is the first arg on RHS of assign */
6873 o2 = cUNOPx(o2)->op_first;
6874 if (!o2 || o2->op_type != OP_NULL)
6876 o2 = cUNOPx(o2)->op_first;
6877 if (!o2 || o2->op_type != OP_PUSHMARK)
6879 if (o2->op_sibling != o)
6882 /* check the array is the same on both sides */
6883 if (oleft->op_type == OP_RV2AV) {
6884 if (oright->op_type != OP_RV2AV
6885 || !cUNOPx(oright)->op_first
6886 || cUNOPx(oright)->op_first->op_type != OP_GV
6887 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6888 cGVOPx_gv(cUNOPx(oright)->op_first)
6892 else if (oright->op_type != OP_PADAV
6893 || oright->op_targ != oleft->op_targ
6897 /* transfer MODishness etc from LHS arg to RHS arg */
6898 oright->op_flags = oleft->op_flags;
6899 o->op_private |= OPpSORT_INPLACE;
6901 /* excise push->gv->rv2av->null->aassign */
6902 o2 = o->op_next->op_next;
6903 op_null(o2); /* PUSHMARK */
6905 if (o2->op_type == OP_GV) {
6906 op_null(o2); /* GV */
6909 op_null(o2); /* RV2AV or PADAV */
6910 o2 = o2->op_next->op_next;
6911 op_null(o2); /* AASSIGN */
6913 o->op_next = o2->op_next;
6919 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6921 LISTOP *enter, *exlist;
6924 enter = (LISTOP *) o->op_next;
6927 if (enter->op_type == OP_NULL) {
6928 enter = (LISTOP *) enter->op_next;
6932 /* for $a (...) will have OP_GV then OP_RV2GV here.
6933 for (...) just has an OP_GV. */
6934 if (enter->op_type == OP_GV) {
6935 gvop = (OP *) enter;
6936 enter = (LISTOP *) enter->op_next;
6939 if (enter->op_type == OP_RV2GV) {
6940 enter = (LISTOP *) enter->op_next;
6946 if (enter->op_type != OP_ENTERITER)
6949 iter = enter->op_next;
6950 if (!iter || iter->op_type != OP_ITER)
6953 expushmark = enter->op_first;
6954 if (!expushmark || expushmark->op_type != OP_NULL
6955 || expushmark->op_targ != OP_PUSHMARK)
6958 exlist = (LISTOP *) expushmark->op_sibling;
6959 if (!exlist || exlist->op_type != OP_NULL
6960 || exlist->op_targ != OP_LIST)
6963 if (exlist->op_last != o) {
6964 /* Mmm. Was expecting to point back to this op. */
6967 theirmark = exlist->op_first;
6968 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6971 if (theirmark->op_sibling != o) {
6972 /* There's something between the mark and the reverse, eg
6973 for (1, reverse (...))
6978 ourmark = ((LISTOP *)o)->op_first;
6979 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
6982 ourlast = ((LISTOP *)o)->op_last;
6983 if (!ourlast || ourlast->op_next != o)
6986 rv2av = ourmark->op_sibling;
6987 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
6988 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
6989 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
6990 /* We're just reversing a single array. */
6991 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
6992 enter->op_flags |= OPf_STACKED;
6995 /* We don't have control over who points to theirmark, so sacrifice
6997 theirmark->op_next = ourmark->op_next;
6998 theirmark->op_flags = ourmark->op_flags;
6999 ourlast->op_next = gvop ? gvop : (OP *) enter;
7002 enter->op_private |= OPpITER_REVERSED;
7003 iter->op_private |= OPpITER_REVERSED;
7019 const char* Perl_custom_op_name(pTHX_ const OP* o)
7021 const IV index = PTR2IV(o->op_ppaddr);
7025 if (!PL_custom_op_names) /* This probably shouldn't happen */
7026 return PL_op_name[OP_CUSTOM];
7028 keysv = sv_2mortal(newSViv(index));
7030 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7032 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7034 return SvPV_nolen(HeVAL(he));
7037 const char* Perl_custom_op_desc(pTHX_ const OP* o)
7039 const IV index = PTR2IV(o->op_ppaddr);
7043 if (!PL_custom_op_descs)
7044 return PL_op_desc[OP_CUSTOM];
7046 keysv = sv_2mortal(newSViv(index));
7048 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7050 return PL_op_desc[OP_CUSTOM];
7052 return SvPV_nolen(HeVAL(he));
7058 /* Efficient sub that returns a constant scalar value. */
7060 const_sv_xsub(pTHX_ CV* cv)
7065 Perl_croak(aTHX_ "usage: %s::%s()",
7066 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7070 ST(0) = (SV*)XSANY.any_ptr;