/* op.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was * our Mr. Bilbo's first cousin on the mother's side (her mother being the * youngest of the Old Took's daughters); and Mr. Drogo was his second * cousin. So Mr. Frodo is his first *and* second cousin, once removed * either way, as the saying is, if you follow me." --the Gaffer */ /* This file contains the functions that create, manipulate and optimize * the OP structures that hold a compiled perl program. * * A Perl program is compiled into a tree of OPs. Each op contains * structural pointers (eg to its siblings and the next op in the * execution sequence), a pointer to the function that would execute the * op, plus any data specific to that op. For example, an OP_CONST op * points to the pp_const() function and to an SV containing the constant * value. When pp_const() is executed, its job is to push that SV onto the * stack. * * OPs are mainly created by the newFOO() functions, which are mainly * called from the parser (in perly.y) as the code is parsed. For example * the Perl code $a + $b * $c would cause the equivalent of the following * to be called (oversimplifying a bit): * * newBINOP(OP_ADD, flags, * newSVREF($a), * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c)) * ) * * Note that during the build of miniperl, a temporary copy of this file * is made, called opmini.c. */ /* Perl's compiler is essentially a 3-pass compiler with interleaved phases: A bottom-up pass A top-down pass An execution-order pass The bottom-up pass is represented by all the "newOP" routines and the ck_ routines. The bottom-upness is actually driven by yacc. So at the point that a ck_ routine fires, we have no idea what the context is, either upward in the syntax tree, or either forward or backward in the execution order. (The bottom-up parser builds that part of the execution order it knows about, but if you follow the "next" links around, you'll find it's actually a closed loop through the top level node. Whenever the bottom-up parser gets to a node that supplies context to its components, it invokes that portion of the top-down pass that applies to that part of the subtree (and marks the top node as processed, so if a node further up supplies context, it doesn't have to take the plunge again). As a particular subcase of this, as the new node is built, it takes all the closed execution loops of its subcomponents and links them into a new closed loop for the higher level node. But it's still not the real execution order. The actual execution order is not known till we get a grammar reduction to a top-level unit like a subroutine or file that will be called by "name" rather than via a "next" pointer. At that point, we can call into peep() to do that code's portion of the 3rd pass. It has to be recursive, but it's recursive on basic blocks, not on tree nodes. */ #include "EXTERN.h" #define PERL_IN_OP_C #include "perl.h" #include "keywords.h" #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) #if defined(PL_OP_SLAB_ALLOC) #ifndef PERL_SLAB_SIZE #define PERL_SLAB_SIZE 2048 #endif void * Perl_Slab_Alloc(pTHX_ int m, size_t sz) { /* * To make incrementing use count easy PL_OpSlab is an I32 * * To make inserting the link to slab PL_OpPtr is I32 ** * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments * Add an overhead for pointer to slab and round up as a number of pointers */ sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *); if ((PL_OpSpace -= sz) < 0) { PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*)); if (!PL_OpPtr) { return NULL; } Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **); /* We reserve the 0'th I32 sized chunk as a use count */ PL_OpSlab = (I32 *) PL_OpPtr; /* Reduce size by the use count word, and by the size we need. * Latter is to mimic the '-=' in the if() above */ PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz; /* Allocation pointer starts at the top. Theory: because we build leaves before trunk allocating at end means that at run time access is cache friendly upward */ PL_OpPtr += PERL_SLAB_SIZE; } assert( PL_OpSpace >= 0 ); /* Move the allocation pointer down */ PL_OpPtr -= sz; assert( PL_OpPtr > (I32 **) PL_OpSlab ); *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */ (*PL_OpSlab)++; /* Increment use count of slab */ assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) ); assert( *PL_OpSlab > 0 ); return (void *)(PL_OpPtr + 1); } void Perl_Slab_Free(pTHX_ void *op) { I32 **ptr = (I32 **) op; I32 *slab = ptr[-1]; assert( ptr-1 > (I32 **) slab ); assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); assert( *slab > 0 ); if (--(*slab) == 0) { # ifdef NETWARE # define PerlMemShared PerlMem # endif PerlMemShared_free(slab); if (slab == PL_OpSlab) { PL_OpSpace = 0; } } } #endif /* * In the following definition, the ", Nullop" is just to make the compiler * think the expression is of the right type: croak actually does a Siglongjmp. */ #define CHECKOP(type,o) \ ((PL_op_mask && PL_op_mask[type]) \ ? ( op_free((OP*)o), \ Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ Nullop ) \ : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) STATIC const char* S_gv_ename(pTHX_ GV *gv) 24 { 24 SV* tmpsv = sv_newmortal(); 24 gv_efullname3(tmpsv, gv, Nullch); 24 return SvPV_nolen_const(tmpsv); } STATIC OP * S_no_fh_allowed(pTHX_ OP *o) ###### { ###### yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function", OP_DESC(o))); ###### return o; } STATIC OP * S_too_few_arguments(pTHX_ OP *o, const char *name) 16 { 16 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name)); 16 return o; } STATIC OP * S_too_many_arguments(pTHX_ OP *o, const char *name) 6 { 6 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name)); 6 return o; } STATIC void S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid) 7 { 7 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", (int)n, name, t, OP_DESC(kid))); } STATIC void S_no_bareword_allowed(pTHX_ const OP *o) 61 { 61 qerror(Perl_mess(aTHX_ "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", cSVOPo_sv)); } /* "register" allocation */ PADOFFSET Perl_allocmy(pTHX_ char *name) 635090 { 635090 PADOFFSET off; /* complain about "my $" etc etc */ 635090 if (!(PL_in_my == KEY_our || isALPHA(name[1]) || (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) || (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2)))) { 2 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { /* 1999-02-27 mjd@plover.com */ 2 char *p; 2 p = strchr(name, '\0'); /* The next block assumes the buffer is at least 205 chars long. At present, it's always at least 256 chars. */ 2 if (p-name > 200) { ###### strcpy(name+200, "..."); ###### p = name+199; } else { 2 p[1] = '\0'; } /* Move everything else down one character */ 6 for (; p-name > 2; p--) 2 *p = *(p-1); 2 name[2] = toCTRL(name[1]); 2 name[1] = '^'; } 2 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name)); } /* check for duplicate declaration */ 635090 pad_check_dup(name, (bool)(PL_in_my == KEY_our), (PL_curstash ? PL_curstash : PL_defstash) ); 635090 if (PL_in_my_stash && *name != '$') { 1 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"", name, PL_in_my == KEY_our ? "our" : "my")); } /* allocate a spare slot and store the name in that slot */ 635090 off = pad_add_name(name, PL_in_my_stash, (PL_in_my == KEY_our /* $_ is always in main::, even with our */ ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) : Nullhv ), 0 /* not fake */ ); 635090 return off; } /* Destructor */ void Perl_op_free(pTHX_ OP *o) 25397547 { dVAR; 25397547 OPCODE type; 25397547 PADOFFSET refcnt; 25397547 if (!o || o->op_static) 25355803 return; 25355803 if (o->op_private & OPpREFCOUNTED) { 1728901 switch (o->op_type) { case OP_LEAVESUB: case OP_LEAVESUBLV: case OP_LEAVEEVAL: case OP_LEAVE: case OP_SCOPE: case OP_LEAVEWRITE: 366706 OP_REFCNT_LOCK; 366706 refcnt = OpREFCNT_dec(o); 366706 OP_REFCNT_UNLOCK; 366706 if (refcnt) 12516 return; 25343287 break; default: 25343287 break; } } 25343287 if (o->op_flags & OPf_KIDS) { 11234144 register OP *kid, *nextkid; 34846211 for (kid = cUNOPo->op_first; kid; kid = nextkid) { 23612067 nextkid = kid->op_sibling; /* Get before next freeing kid */ 23612067 op_free(kid); } } 25343287 type = o->op_type; 25343287 if (type == OP_NULL) 3935573 type = (OPCODE)o->op_targ; /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ 25343287 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) 2388025 cop_free((COP*)o); 25343287 op_clear(o); 25343287 FreeOp(o); #ifdef DEBUG_LEAKING_SCALARS if (PL_op == o) PL_op = Nullop; #endif } void Perl_op_clear(pTHX_ OP *o) 28359880 { dVAR; 28359880 switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ case OP_ENTEREVAL: /* Was holding hints. */ 3951762 o->op_targ = 0; 3951762 break; default: 18371238 if (!(o->op_flags & OPf_REF) || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst))) 1456277 break; /* FALL THROUGH */ case OP_GVSV: case OP_GV: case OP_AELEMFAST: 1456277 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) { /* not an OP_PADAV replacement */ #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { /* No GvIN_PAD_off(cGVOPo_gv) here, because other references * may still exist on the pad */ pad_swipe(cPADOPo->op_padix, TRUE); cPADOPo->op_padix = 0; } #else 1440787 SvREFCNT_dec(cSVOPo->op_sv); 1440787 cSVOPo->op_sv = Nullsv; #endif } 1440787 break; case OP_METHOD_NAMED: case OP_CONST: 4357772 SvREFCNT_dec(cSVOPo->op_sv); 4357772 cSVOPo->op_sv = Nullsv; #ifdef USE_ITHREADS /** Bug #15654 Even if op_clear does a pad_free for the target of the op, pad_free doesn't actually remove the sv that exists in the pad; instead it lives on. This results in that it could be reused as a target later on when the pad was reallocated. **/ if(o->op_targ) { pad_swipe(o->op_targ,1); o->op_targ = 0; } #endif 4357772 break; case OP_GOTO: case OP_NEXT: case OP_LAST: case OP_REDO: 60131 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) 51862 break; /* FALL THROUGH */ case OP_TRANS: 13413 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { 47 SvREFCNT_dec(cSVOPo->op_sv); 47 cSVOPo->op_sv = Nullsv; } else { 13366 Safefree(cPVOPo->op_pv); 13366 cPVOPo->op_pv = Nullch; } 13366 break; case OP_SUBST: 53389 op_free(cPMOPo->op_pmreplroot); 53389 goto clear_pmop; case OP_PUSHRE: #ifdef USE_ITHREADS if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) { /* No GvIN_PAD_off here, because other references may still * exist on the pad */ pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE); } #else 8472 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot); #endif /* FALL THROUGH */ case OP_MATCH: case OP_QR: clear_pmop: { 160789 HV *pmstash = PmopSTASH(cPMOPo); 160789 if (pmstash && SvREFCNT(pmstash)) { 149836 MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); 149836 if (mg) { 149836 PMOP *pmop = (PMOP*) mg->mg_obj; 149836 PMOP *lastpmop = NULL; 1444779 while (pmop) { 1444779 if (cPMOPo == pmop) { 149836 if (lastpmop) 111331 lastpmop->op_pmnext = pmop->op_pmnext; else 38505 mg->mg_obj = (SV*) pmop->op_pmnext; 38505 break; } 1294943 lastpmop = pmop; 1294943 pmop = pmop->op_pmnext; } } } PmopSTASH_free(cPMOPo); } 160789 cPMOPo->op_pmreplroot = Nullop; /* we use the "SAFE" version of the PM_ macros here * since sv_clean_all might release some PMOPs * after PL_regex_padav has been cleared * and the clearing of PL_regex_padav needs to * happen before sv_clean_all */ 160789 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo)); 160789 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL); #ifdef USE_ITHREADS if(PL_regex_pad) { /* We could be in destruction */ av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]); SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]); PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset); } #endif 28359880 break; } 28359880 if (o->op_targ > 0) { 5851428 pad_free(o->op_targ); 5851428 o->op_targ = 0; } } STATIC void S_cop_free(pTHX_ COP* cop) 2388025 { 2388025 Safefree(cop->cop_label); /* FIXME: treaddead ??? */ 2388025 CopFILE_free(cop); CopSTASH_free(cop); 2388025 if (! specialWARN(cop->cop_warnings)) 34807 SvREFCNT_dec(cop->cop_warnings); 2388025 if (! specialCopIO(cop->cop_io)) { #ifdef USE_ITHREADS #if 0 STRLEN len; char *s = SvPV(cop->cop_io,len); Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */ #endif #else 26 SvREFCNT_dec(cop->cop_io); #endif } } void Perl_op_null(pTHX_ OP *o) 3016634 { dVAR; 3016634 if (o->op_type == OP_NULL) 41 return; 3016593 op_clear(o); 3016593 o->op_targ = o->op_type; 3016593 o->op_type = OP_NULL; 3016593 o->op_ppaddr = PL_ppaddr[OP_NULL]; } void Perl_op_refcnt_lock(pTHX) ###### { dVAR; ###### OP_REFCNT_LOCK; } void Perl_op_refcnt_unlock(pTHX) ###### { dVAR; ###### OP_REFCNT_UNLOCK; } /* Contextualizers */ #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) OP * Perl_linklist(pTHX_ OP *o) 9806890 { 9806890 if (o->op_next) 17335 return o->op_next; /* establish postfix order */ 9789555 if (cUNOPo->op_first) { 9758927 register OP *kid; 9758927 o->op_next = LINKLIST(cUNOPo->op_first); 30837684 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 21078757 if (kid->op_sibling) 11319830 kid->op_next = LINKLIST(kid->op_sibling); else 9758927 kid->op_next = o; } } else 30628 o->op_next = o; 9789555 return o->op_next; } OP * Perl_scalarkids(pTHX_ OP *o) 3934 { 3934 if (o && o->op_flags & OPf_KIDS) { 3934 OP *kid; 7868 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 3934 scalar(kid); } 3934 return o; } STATIC OP * S_scalarboolean(pTHX_ OP *o) 838502 { 838502 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { 4 if (ckWARN(WARN_SYNTAX)) { 1 const line_t oldline = CopLINE(PL_curcop); 1 if (PL_copline != NOLINE) 1 CopLINE_set(PL_curcop, PL_copline); 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); 1 CopLINE_set(PL_curcop, oldline); } } 838502 return scalar(o); } OP * Perl_scalar(pTHX_ OP *o) 35092526 { dVAR; 35092526 OP *kid; /* assumes no premature commitment */ 35092526 if (!o || (o->op_flags & OPf_WANT) || PL_error_count || o->op_type == OP_RETURN) { 18361743 return o; } 16730783 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; 16730783 switch (o->op_type) { case OP_REPEAT: 3344 scalar(cBINOPo->op_first); 3344 break; case OP_OR: case OP_AND: case OP_COND_EXPR: 434216 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 239298 scalar(kid); 7 break; case OP_SPLIT: 7 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { 7 if (!kPMOP->op_pmreplroot) 6 deprecate_old("implicit split to @_"); } /* FALL THROUGH */ case OP_MATCH: case OP_QR: case OP_SUBST: case OP_NULL: default: 16296827 if (o->op_flags & OPf_KIDS) { 15758785 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 9816246 scalar(kid); } 11485 break; case OP_LEAVE: case OP_LEAVETRY: 11485 kid = cLISTOPo->op_first; 11485 scalar(kid); 43007 while ((kid = kid->op_sibling)) { 31522 if (kid->op_sibling) 20037 scalarvoid(kid); else 11485 scalar(kid); } 11485 WITH_THR(PL_curcop = &PL_compiling); 11485 break; case OP_SCOPE: case OP_LINESEQ: case OP_LIST: 1246987 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 1022782 if (kid->op_sibling) 798577 scalarvoid(kid); else 224205 scalar(kid); } 224205 WITH_THR(PL_curcop = &PL_compiling); 224205 break; case OP_SORT: 4 if (ckWARN(WARN_VOID)) 1 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); } 16730783 return o; } OP * Perl_scalarvoid(pTHX_ OP *o) 9869337 { dVAR; 9869337 OP *kid; 9869337 const char* useless = 0; 9869337 SV* sv; 9869337 U8 want; 9869337 if (o->op_type == OP_NEXTSTATE || o->op_type == OP_SETSTATE || o->op_type == OP_DBSTATE || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_SETSTATE || o->op_targ == OP_DBSTATE))) 4637165 PL_curcop = (COP*)o; /* for warning below */ /* assumes no premature commitment */ 9869337 want = o->op_flags & OPf_WANT; 9869337 if ((want && want != OPf_WANT_SCALAR) || PL_error_count || o->op_type == OP_RETURN) { 3876459 return o; } 5992878 if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { 32885 return scalar(o); /* As if inside SASSIGN */ } 5959993 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 5959993 switch (o->op_type) { default: 1406876 if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) 1342523 break; /* FALL THROUGH */ case OP_REPEAT: 64362 if (o->op_flags & OPf_STACKED) 64273 break; 121 goto func_ops; case OP_SUBSTR: 121 if (o->op_private == 4) 118 break; /* FALL THROUGH */ case OP_GVSV: case OP_WANTARRAY: case OP_GV: case OP_PADSV: case OP_PADAV: case OP_PADHV: case OP_PADANY: case OP_AV2ARYLEN: case OP_REF: case OP_REFGEN: case OP_SREFGEN: case OP_DEFINED: case OP_HEX: case OP_OCT: case OP_LENGTH: case OP_VEC: case OP_INDEX: case OP_RINDEX: case OP_SPRINTF: case OP_AELEM: case OP_AELEMFAST: case OP_ASLICE: case OP_HELEM: case OP_HSLICE: case OP_UNPACK: case OP_PACK: case OP_JOIN: case OP_LSLICE: case OP_ANONLIST: case OP_ANONHASH: case OP_SORT: case OP_REVERSE: case OP_RANGE: case OP_FLIP: case OP_FLOP: case OP_CALLER: case OP_FILENO: case OP_EOF: case OP_TELL: case OP_GETSOCKNAME: case OP_GETPEERNAME: case OP_READLINK: case OP_TELLDIR: case OP_GETPPID: case OP_GETPGRP: case OP_GETPRIORITY: case OP_TIME: case OP_TMS: case OP_LOCALTIME: case OP_GMTIME: case OP_GHBYNAME: case OP_GHBYADDR: case OP_GHOSTENT: case OP_GNBYNAME: case OP_GNBYADDR: case OP_GNETENT: case OP_GPBYNAME: case OP_GPBYNUMBER: case OP_GPROTOENT: case OP_GSBYNAME: case OP_GSBYPORT: case OP_GSERVENT: case OP_GPWNAM: case OP_GPWUID: case OP_GGRNAM: case OP_GGRGID: case OP_GETLOGIN: case OP_PROTOTYPE: func_ops: 98206 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) 286 useless = OP_DESC(o); 286 break; case OP_NOT: 1 kid = cUNOPo->op_first; 1 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && kid->op_type != OP_TRANS) { 1 goto func_ops; } ###### useless = "negative pattern binding (!~)"; ###### break; case OP_RV2GV: case OP_RV2SV: case OP_RV2AV: case OP_RV2HV: 33354 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) 23 useless = "a variable"; 23 break; case OP_CONST: 3579 sv = cSVOPo_sv; 3579 if (cSVOPo->op_private & OPpCONST_STRICT) 3 no_bareword_allowed(o); else { 3576 if (ckWARN(WARN_VOID)) { 2076 useless = "a constant"; /* don't warn on optimised away booleans, eg * use constant Foo, 5; Foo || print; */ 2076 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) 1798 useless = 0; /* the constants 0 and 1 are permitted as they are conventionally used as dummies in constructs like 1 while some_condition_with_side_effects; */ 278 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) 276 useless = 0; 2 else if (SvPOK(sv)) { /* perl4's way of mixing documentation and code (before the invention of POD) was based on a trick to mix nroff and perl code. The trick was built upon these three nroff macros being used in void context. The pink camel has the details in the script wrapman near page 319. */ 1 if (strnEQ(SvPVX_const(sv), "di", 2) || strnEQ(SvPVX_const(sv), "ds", 2) || strnEQ(SvPVX_const(sv), "ig", 2)) ###### useless = 0; } } } 3579 op_null(o); /* don't execute or even remember it */ 3579 break; case OP_POSTINC: 13447 o->op_type = OP_PREINC; /* pre-increment is faster */ 13447 o->op_ppaddr = PL_ppaddr[OP_PREINC]; 13447 break; case OP_POSTDEC: 1222 o->op_type = OP_PREDEC; /* pre-decrement is faster */ 1222 o->op_ppaddr = PL_ppaddr[OP_PREDEC]; 1222 break; case OP_OR: case OP_AND: case OP_DOR: case OP_COND_EXPR: 1235379 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 673645 scalarvoid(kid); 580709 break; case OP_NULL: 580709 if (o->op_flags & OPf_STACKED) 3461 break; /* FALL THROUGH */ case OP_NEXTSTATE: case OP_DBSTATE: case OP_ENTERTRY: case OP_ENTER: 3162015 if (!(o->op_flags & OPf_KIDS)) 2585077 break; /* FALL THROUGH */ case OP_SCOPE: case OP_LEAVE: case OP_LEAVETRY: case OP_LEAVELOOP: case OP_LINESEQ: case OP_LIST: 3929768 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 2839883 scalarvoid(kid); 3934 break; case OP_ENTEREVAL: 3934 scalarkids(o); 3934 break; case OP_REQUIRE: /* all requires must return a boolean value */ 159090 o->op_flags &= ~OPf_WANT; /* FALL THROUGH */ case OP_SCALAR: 159095 return scalar(o); case OP_SPLIT: 81 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { 81 if (!kPMOP->op_pmreplroot) 9 deprecate_old("implicit split to @_"); } 5800894 break; } 5800894 if (useless && ckWARN(WARN_VOID)) 80 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless); 5800891 return o; } OP * Perl_listkids(pTHX_ OP *o) 2808023 { 2808023 if (o && o->op_flags & OPf_KIDS) { 2808023 OP *kid; 9062762 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 6254739 list(kid); } 2808023 return o; } OP * Perl_list(pTHX_ OP *o) 7761601 { dVAR; 7761601 OP *kid; /* assumes no premature commitment */ 7761601 if (!o || (o->op_flags & OPf_WANT) || PL_error_count || o->op_type == OP_RETURN) { 5736022 return o; } 2025579 if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { ###### return o; /* As if inside SASSIGN */ } 2025579 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; 2025579 switch (o->op_type) { case OP_FLOP: case OP_REPEAT: 5549 list(cBINOPo->op_first); 5549 break; case OP_OR: case OP_AND: case OP_COND_EXPR: 52114 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 33927 list(kid); 1967855 break; default: case OP_MATCH: case OP_QR: case OP_SUBST: case OP_NULL: 1967855 if (!(o->op_flags & OPf_KIDS)) 675202 break; 1292653 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) { 1028 list(cBINOPo->op_first); 1028 return gen_constant_list(o); } case OP_LIST: 1315409 listkids(o); 1315409 break; case OP_LEAVE: case OP_LEAVETRY: 4373 kid = cLISTOPo->op_first; 4373 list(kid); 15946 while ((kid = kid->op_sibling)) { 11573 if (kid->op_sibling) 7200 scalarvoid(kid); else 4373 list(kid); } 4373 WITH_THR(PL_curcop = &PL_compiling); 4373 break; case OP_SCOPE: case OP_LINESEQ: 17495 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 11665 if (kid->op_sibling) 5835 scalarvoid(kid); else 5830 list(kid); } 5830 WITH_THR(PL_curcop = &PL_compiling); 5830 break; case OP_REQUIRE: /* all requires must return a boolean value */ 1 o->op_flags &= ~OPf_WANT; 1 return scalar(o); } 2024550 return o; } OP * Perl_scalarseq(pTHX_ OP *o) 1339510 { 1339510 if (o) { 1332461 if (o->op_type == OP_LINESEQ || o->op_type == OP_SCOPE || o->op_type == OP_LEAVE || o->op_type == OP_LEAVETRY) { 1124644 OP *kid; 7757236 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 6632595 if (kid->op_sibling) { 5507954 scalarvoid(kid); } } 1124641 PL_curcop = &PL_compiling; } 1332458 o->op_flags &= ~OPf_PARENS; 1332458 if (PL_hints & HINT_BLOCK_SCOPE) 1003351 o->op_flags |= OPf_PARENS; } else 7049 o = newOP(OP_STUB, 0); 1339507 return o; } STATIC OP * S_modkids(pTHX_ OP *o, I32 type) 306638 { 306638 if (o && o->op_flags & OPf_KIDS) { 279746 OP *kid; 559492 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 279746 mod(kid, type); } 306638 return o; } /* Propagate lvalue ("modifiable") context to an op and it's children. * 'type' represents the context type, roughly based on the type of op that * would do the modifying, although local() is represented by OP_NULL. * It's responsible for detecting things that can't be modified, flag * things that need to behave specially in an lvalue context (e.g., "$$x = 5" * might have to vivify a reference in $x), and so on. * * For example, "$a+1 = 2" would cause mod() to be called with o being * OP_ADD and type being OP_SASSIGN, and would output an error. */ OP * Perl_mod(pTHX_ OP *o, I32 type) 3468262 { dVAR; 3468262 OP *kid; /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ 3468262 int localize = -1; 3468262 if (!o || PL_error_count) 1385 return o; 3466877 if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { 70 return o; } 3466807 switch (o->op_type) { case OP_UNDEF: 3908 localize = 0; 3908 PL_modcount++; 3908 return o; case OP_CONST: 360069 if (!(o->op_private & (OPpCONST_ARYBASE))) 360050 goto nomod; 19 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { 14 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv); 14 PL_eval_start = 0; } 5 else if (!type) { 2 SAVEI32(PL_compiling.cop_arybase); 2 PL_compiling.cop_arybase = 0; } 3 else if (type == OP_REFGEN) ###### goto nomod; else 3 Perl_croak(aTHX_ "That use of $[ is unsupported"); 2062 break; case OP_STUB: 2062 if (o->op_flags & OPf_PARENS) 2062 break; 77895 goto nomod; case OP_ENTERSUB: 77895 if ((type == OP_UNDEF || type == OP_REFGEN) && !(o->op_flags & OPf_STACKED)) { 46193 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 46193 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 46193 assert(cUNOPo->op_first->op_type == OP_NULL); 46193 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ 46193 break; } 31702 else if (o->op_private & OPpENTERSUB_NOMOD) 1 return o; else { /* lvalue subroutine call */ 31701 o->op_private |= OPpLVAL_INTRO; 31701 PL_modcount = RETURN_UNLIMITED_NUMBER; 31701 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { /* Backward compatibility mode: */ 31632 o->op_private |= OPpENTERSUB_INARGS; 31632 break; } else { /* Compile-time error message: */ 69 OP *kid = cUNOPo->op_first; 69 CV *cv; 69 OP *okid; 69 if (kid->op_type == OP_PUSHMARK) 4 goto skip_kids; 65 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) ###### Perl_croak(aTHX_ "panic: unexpected lvalue entersub " "args: type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); 65 kid = kLISTOP->op_first; skip_kids: 161 while (kid->op_sibling) 92 kid = kid->op_sibling; 69 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { /* Indirect call */ 4 if (kid->op_type == OP_METHOD_NAMED || kid->op_type == OP_METHOD) { 4 UNOP *newop; 4 NewOp(1101, newop, 1, UNOP); 4 newop->op_type = OP_RV2CV; 4 newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; 4 newop->op_first = Nullop; 4 newop->op_next = (OP*)newop; 4 kid->op_sibling = (OP*)newop; 4 newop->op_private |= OPpLVAL_INTRO; 4 break; } ###### if (kid->op_type != OP_RV2CV) ###### Perl_croak(aTHX_ "panic: unexpected lvalue entersub " "entry via type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); ###### kid->op_private |= OPpLVAL_INTRO; ###### break; /* Postpone until runtime */ } 65 okid = kid; 65 kid = kUNOP->op_first; 65 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) ###### kid = kUNOP->op_first; 65 if (kid->op_type == OP_NULL) ###### Perl_croak(aTHX_ "Unexpected constant lvalue entersub " "entry via type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); 65 if (kid->op_type != OP_GV) { /* Restore RV2CV to check lvalueness */ restore_2cv: 4 if (kid->op_next && kid->op_next != kid) { /* Happens? */ ###### okid->op_next = kid->op_next; ###### kid->op_next = okid; } else 4 okid->op_next = Nullop; 4 okid->op_type = OP_RV2CV; 4 okid->op_targ = 0; 4 okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; 4 okid->op_private |= OPpLVAL_INTRO; 4 break; } 62 cv = GvCV(kGVOP_gv); 62 if (!cv) 1 goto restore_2cv; 61 if (CvLVALUE(cv)) 57 break; } } /* FALL THROUGH */ default: nomod: /* grep, foreach, subcalls, refgen */ 630442 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) 28 break; 28 yyerror(Perl_form(aTHX_ "Can't modify %s in %s", (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) ? "do block" : (o->op_type == OP_ENTERSUB ? "non-lvalue subroutine call" : OP_DESC(o))), type ? PL_op_desc[type] : "local")); 28 return o; case OP_PREINC: case OP_PREDEC: case OP_POW: case OP_MULTIPLY: case OP_DIVIDE: case OP_MODULO: case OP_REPEAT: case OP_ADD: case OP_SUBTRACT: case OP_CONCAT: case OP_LEFT_SHIFT: case OP_RIGHT_SHIFT: case OP_BIT_AND: case OP_BIT_XOR: case OP_BIT_OR: case OP_I_MULTIPLY: case OP_I_DIVIDE: case OP_I_MODULO: case OP_I_ADD: case OP_I_SUBTRACT: 9252 if (!(o->op_flags & OPf_STACKED)) 7521 goto nomod; 1731 PL_modcount++; 1731 break; case OP_COND_EXPR: 4967 localize = 1; 14901 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 9934 mod(kid, type); 334273 break; case OP_RV2AV: case OP_RV2HV: 334273 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { 34 PL_modcount = RETURN_UNLIMITED_NUMBER; 34 return o; /* Treat \(@foo) like ordinary list. */ } /* FALL THROUGH */ case OP_RV2GV: 375818 if (scalar_mod_type(o, type)) 1 goto nomod; 375817 ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_ASLICE: case OP_HSLICE: 383996 if (type == OP_LEAVESUBLV) 6 o->op_private |= OPpMAYBE_LVSUB; 383996 localize = 1; /* FALL THROUGH */ case OP_AASSIGN: case OP_NEXTSTATE: case OP_DBSTATE: 384078 PL_modcount = RETURN_UNLIMITED_NUMBER; 384078 break; case OP_RV2SV: 267244 ref(cUNOPo->op_first, o->op_type); 267244 localize = 1; /* FALL THROUGH */ case OP_GV: case OP_AV2ARYLEN: 268025 PL_hints |= HINT_BLOCK_SCOPE; case OP_SASSIGN: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: 272844 PL_modcount++; 272844 break; case OP_AELEMFAST: ###### localize = -1; ###### PL_modcount++; ###### break; case OP_PADAV: case OP_PADHV: 132972 PL_modcount = RETURN_UNLIMITED_NUMBER; 132972 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) 4 return o; /* Treat \(@foo) like ordinary list. */ 132968 if (scalar_mod_type(o, type)) 1 goto nomod; 132967 if (type == OP_LEAVESUBLV) 3 o->op_private |= OPpMAYBE_LVSUB; /* FALL THROUGH */ case OP_PADSV: 1317582 PL_modcount++; 1317582 if (!type) /* local() */ 1 Perl_croak(aTHX_ "Can't localize lexical variable %s", PAD_COMPNAME_PV(o->op_targ)); 292295 break; case OP_PUSHMARK: 292295 localize = 0; 292295 break; case OP_KEYS: 5519 if (type != OP_SASSIGN) 5515 goto nomod; 1605 goto lvalue_func; case OP_SUBSTR: 1605 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ 8 goto nomod; /* FALL THROUGH */ case OP_POS: case OP_VEC: 10070 if (type == OP_LEAVESUBLV) 4 o->op_private |= OPpMAYBE_LVSUB; lvalue_func: 10074 pad_free(o->op_targ); 10074 o->op_targ = pad_alloc(o->op_type, SVs_PADMY); 10074 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL); 10074 if (o->op_flags & OPf_KIDS) 10074 mod(cBINOPo->op_first->op_sibling, type); 10074 break; case OP_AELEM: case OP_HELEM: 169902 ref(cBINOPo->op_first, o->op_type); 169902 if (type == OP_ENTERSUB && !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) 41682 o->op_private |= OPpLVAL_DEFER; 169902 if (type == OP_LEAVESUBLV) 8 o->op_private |= OPpMAYBE_LVSUB; 169902 localize = 1; 169902 PL_modcount++; 169902 break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: case OP_LINESEQ: 47 localize = 0; 47 if (o->op_flags & OPf_KIDS) 47 mod(cLISTOPo->op_last, type); 47 break; case OP_NULL: 204277 localize = 0; 204277 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ 706 goto nomod; 203571 else if (!(o->op_flags & OPf_KIDS)) 1 break; 203570 if (o->op_targ != OP_LIST) { 6625 mod(cBINOPo->op_first, type); 6625 break; } /* FALL THROUGH */ case OP_LIST: 292295 localize = 0; 1067644 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 775350 mod(kid, type); 6 break; case OP_RETURN: 6 if (type != OP_LEAVESUBLV) ###### goto nomod; 3462827 break; /* mod()ing was handled by ck_return() */ } /* [20011101.069] File test operators interpret OPf_REF to mean that their argument is a filehandle; thus \stat(".") should not set it. AMS 20011102 */ 3462827 if (type == OP_REFGEN && PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)) 4 return o; 3462823 if (type != OP_LEAVESUBLV) 3462722 o->op_flags |= OPf_MOD; 3462823 if (type == OP_AASSIGN || type == OP_SASSIGN) 1201076 o->op_flags |= OPf_SPECIAL|OPf_REF; 2261747 else if (!type) { /* local() */ 58000 switch (localize) { case 1: 45520 o->op_private |= OPpLVAL_INTRO; 45520 o->op_flags &= ~OPf_SPECIAL; 45520 PL_hints |= HINT_BLOCK_SCOPE; 45520 break; case 0: 30 break; case -1: 30 if (ckWARN(WARN_SYNTAX)) { 28 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Useless localization of %s", OP_DESC(o)); } } } 2203747 else if (type != OP_GREPSTART && type != OP_ENTERSUB && type != OP_LEAVESUBLV) 1047079 o->op_flags |= OPf_REF; 3462823 return o; } STATIC bool S_scalar_mod_type(pTHX_ const OP *o, I32 type) 508786 { 508786 switch (type) { case OP_SASSIGN: 24665 if (o->op_type == OP_RV2GV) 24665 return FALSE; /* FALL THROUGH */ case OP_PREINC: case OP_PREDEC: case OP_POSTINC: case OP_POSTDEC: case OP_I_PREINC: case OP_I_PREDEC: case OP_I_POSTINC: case OP_I_POSTDEC: case OP_POW: case OP_MULTIPLY: case OP_DIVIDE: case OP_MODULO: case OP_REPEAT: case OP_ADD: case OP_SUBTRACT: case OP_I_MULTIPLY: case OP_I_DIVIDE: case OP_I_MODULO: case OP_I_ADD: case OP_I_SUBTRACT: case OP_LEFT_SHIFT: case OP_RIGHT_SHIFT: case OP_BIT_AND: case OP_BIT_XOR: case OP_BIT_OR: case OP_CONCAT: case OP_SUBST: case OP_TRANS: case OP_READ: case OP_SYSREAD: case OP_RECV: case OP_ANDASSIGN: case OP_ORASSIGN: 2 return TRUE; default: 484119 return FALSE; } } STATIC bool S_is_handle_constructor(pTHX_ const OP *o, I32 numargs) 10881 { 10881 switch (o->op_type) { case OP_PIPE_OP: case OP_SOCKPAIR: 140 if (numargs == 2) 70 return TRUE; /* FALL THROUGH */ case OP_SYSOPEN: case OP_OPEN: case OP_SELECT: /* XXX c.f. SelectSaver.pm */ case OP_SOCKET: case OP_OPEN_DIR: case OP_ACCEPT: 3895 if (numargs == 1) 3883 return TRUE; /* FALL THROUGH */ default: 6928 return FALSE; } } OP * Perl_refkids(pTHX_ OP *o, I32 type) 91533 { 91533 if (o && o->op_flags & OPf_KIDS) { 91533 OP *kid; 183066 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 91533 ref(kid, type); } 91533 return o; } OP * Perl_ref(pTHX_ OP *o, I32 type) 2387799 { dVAR; 2387799 OP *kid; 2387799 if (!o || PL_error_count) 3 return o; 2387796 switch (o->op_type) { case OP_ENTERSUB: 10696 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { 8712 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 8712 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 8712 assert(cUNOPo->op_first->op_type == OP_NULL); 8712 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ 8712 o->op_flags |= OPf_SPECIAL; } 8712 break; case OP_COND_EXPR: 15 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 10 ref(kid, type); 20894 break; case OP_RV2SV: 20894 if (type == OP_DEFINED) 9073 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 20894 ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_PADSV: 456588 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 366432 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : type == OP_RV2HV ? OPpDEREF_HV : OPpDEREF_SV); 366432 o->op_flags |= OPf_MOD; } 366432 break; case OP_THREADSV: ###### o->op_flags |= OPf_MOD; /* XXX ??? */ ###### break; case OP_RV2AV: case OP_RV2HV: 645881 o->op_flags |= OPf_REF; /* FALL THROUGH */ case OP_RV2GV: 708066 if (type == OP_DEFINED) 78 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 708066 ref(cUNOPo->op_first, o->op_type); 708066 break; case OP_PADAV: case OP_PADHV: 142682 o->op_flags |= OPf_REF; 142682 break; case OP_SCALAR: case OP_NULL: 2660 if (!(o->op_flags & OPf_KIDS)) ###### break; 2660 ref(cBINOPo->op_first, type); 2660 break; case OP_AELEM: case OP_HELEM: 55551 ref(cBINOPo->op_first, o->op_type); 55551 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 39697 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : type == OP_RV2HV ? OPpDEREF_HV : OPpDEREF_SV); 39697 o->op_flags |= OPf_MOD; } 39697 break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: case OP_LIST: 72449 if (!(o->op_flags & OPf_KIDS)) ###### break; 72449 ref(cLISTOPo->op_last, type); break; default: 2387796 break; } 2387796 return scalar(o); } STATIC OP * S_dup_attrlist(pTHX_ OP *o) 77 { 77 OP *rop = Nullop; /* An attrlist is either a simple OP_CONST or an OP_LIST with kids, * where the first kid is OP_PUSHMARK and the remaining ones * are OP_CONST. We need to push the OP_CONST values. */ 77 if (o->op_type == OP_CONST) 70 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv)); else { 7 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); 28 for (o = cLISTOPo->op_first; o; o=o->op_sibling) { 21 if (o->op_type == OP_CONST) 14 rop = append_elem(OP_LIST, rop, newSVOP(OP_CONST, o->op_flags, 14 SvREFCNT_inc(cSVOPo->op_sv))); } } 77 return rop; } STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) 77 { dVAR; 77 SV *stashsv; /* fake up C */ 77 ENTER; /* need to protect against side-effects of 'use' */ 77 SAVEINT(PL_expect); 77 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; #define ATTRSMODULE "attributes" #define ATTRSMODULE_PM "attributes.pm" 77 if (for_my) { /* Don't force the C if we don't need it. */ 44 SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, 44 sizeof(ATTRSMODULE_PM)-1, 0); 44 if (svp && *svp != &PL_sv_undef) ; /* already in %INC */ else ###### Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), Nullsv); } else { 33 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), Nullsv, prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, stashsv), prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newRV(target)), dup_attrlist(attrs)))); } 70 LEAVE; } STATIC void S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) 44 { 44 OP *pack, *imop, *arg; 44 SV *meth, *stashsv; 44 if (!attrs) ###### return; assert(target->op_type == OP_PADSV || target->op_type == OP_PADHV || 44 target->op_type == OP_PADAV); /* Ensure that attributes.pm is loaded. */ 44 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE); /* Need package name for method call. */ 44 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); /* Build up the real arg-list. */ 44 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; 44 arg = newOP(OP_PADSV, 0); 44 arg->op_targ = target->op_targ; 44 arg = prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, stashsv), prepend_elem(OP_LIST, newUNOP(OP_REFGEN, 0, mod(arg, OP_REFGEN)), dup_attrlist(attrs))); /* Fake up a method call to import */ 44 meth = newSVpvn_share("import", 6, 0); 44 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(arg)), newSVOP(OP_METHOD_NAMED, 0, meth))); 44 imop->op_private |= OPpENTERSUB_NOMOD; /* Combine the ops. */ 44 *imopsp = append_elem(OP_LIST, *imopsp, imop); } /* =notfor apidoc apply_attrs_string Attempts to apply a list of attributes specified by the C and C arguments to the subroutine identified by the C argument which is expected to be associated with the package identified by the C argument (see L). It gets this wrong, though, in that it does not correctly identify the boundaries of the individual attribute specifications within C. This is not really intended for the public API, but has to be listed here for systems such as AIX which need an explicit export list for symbols. (It's called from XS code in support of the C keyword from F.) Patches to fix it to respect attribute syntax properly would be welcome. =cut */ void Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, const char *attrstr, STRLEN len) ###### { ###### OP *attrs = Nullop; ###### if (!len) { ###### len = strlen(attrstr); } ###### while (len) { ###### for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; ###### if (len) { ###### const char *sstr = attrstr; ###### for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; ###### attrs = append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, newSVpvn(sstr, attrstr-sstr))); } } ###### Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), Nullsv, prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newRV((SV*)cv)), attrs))); } STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) 804990 { 804990 I32 type; 804990 if (!o || PL_error_count) 10 return o; 804980 type = o->op_type; 804980 if (type == OP_LIST) { 84786 OP *kid; 410750 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 325964 my_kid(kid, attrs, imopsp); 720194 } else if (type == OP_UNDEF) { 327 return o; 719867 } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ 46669 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ 6 yyerror(Perl_form(aTHX_ "Can't declare %s in %s", OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); 46663 } else if (attrs) { 2 GV *gv = cGVOPx_gv(cUNOPo->op_first); 2 PL_in_my = FALSE; 2 PL_in_my_stash = Nullhv; 2 apply_attrs(GvSTASH(gv), (type == OP_RV2SV ? GvSV(gv) : type == OP_RV2AV ? (SV*)GvAV(gv) : type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv), attrs, FALSE); } 46669 o->op_private |= OPpOUR_INTRO; 46669 return o; } 673198 else if (type != OP_PADSV && type != OP_PADAV && type != OP_PADHV && type != OP_PUSHMARK) { ###### yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); ###### return o; } 673198 else if (attrs && type != OP_PUSHMARK) { 44 HV *stash; 44 PL_in_my = FALSE; 44 PL_in_my_stash = Nullhv; /* check for C when deciding package */ 44 stash = PAD_COMPNAME_TYPE(o->op_targ); 44 if (!stash) 37 stash = PL_curstash; 44 apply_attrs_my(stash, o, attrs, imopsp); } 757984 o->op_flags |= OPf_MOD; 757984 o->op_private |= OPpLVAL_INTRO; 757984 return o; } OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs) 479026 { 479026 OP *rops = Nullop; 479026 int maybe_scalar = 0; /* [perl #17376]: this appears to be premature, and results in code such as C< our(%x); > executing in list mode rather than void mode */ #if 0 if (o->op_flags & OPf_PARENS) list(o); else maybe_scalar = 1; #else 479026 maybe_scalar = 1; #endif 479026 if (attrs) 46 SAVEFREEOP(attrs); 479026 o = my_kid(o, attrs, &rops); 479026 if (rops) { 42 if (maybe_scalar && o->op_type == OP_PADSV) { 26 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o)); 26 o->op_private |= OPpLVAL_INTRO; } else 16 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); } 479026 PL_in_my = FALSE; 479026 PL_in_my_stash = Nullhv; 479026 return o; } OP * Perl_my(pTHX_ OP *o) 478132 { 478132 return my_attrs(o, Nullop); } OP * Perl_sawparens(pTHX_ OP *o) 378092 { 378092 if (o) 378092 o->op_flags |= OPf_PARENS; 378092 return o; } OP * Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) 130387 { 130387 OP *o; 130387 bool ismatchop = 0; 130387 if (ckWARN(WARN_MISC) && (left->op_type == OP_RV2AV || left->op_type == OP_RV2HV || left->op_type == OP_PADAV || left->op_type == OP_PADHV)) { 12 const char *desc = PL_op_desc[(right->op_type == OP_SUBST || right->op_type == OP_TRANS) 12 ? right->op_type : OP_MATCH]; 12 const char *sample = ((left->op_type == OP_RV2AV || left->op_type == OP_PADAV) 12 ? "@array" : "%hash"); 12 Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %s will act on scalar(%s)", desc, sample, sample); } 130387 if (right->op_type == OP_CONST && cSVOPx(right)->op_private & OPpCONST_BARE && cSVOPx(right)->op_private & OPpCONST_STRICT) { 1 no_bareword_allowed(right); } 130387 ismatchop = right->op_type == OP_MATCH || right->op_type == OP_SUBST || right->op_type == OP_TRANS; 130387 if (ismatchop && right->op_private & OPpTARGET_MY) { 16 right->op_targ = 0; 16 right->op_private &= ~OPpTARGET_MY; } 130387 if (!(right->op_flags & OPf_STACKED) && ismatchop) { 124281 right->op_flags |= OPf_STACKED; 124281 if (right->op_type != OP_MATCH && ! (right->op_type == OP_TRANS && right->op_private & OPpTRANS_IDENTICAL)) 48428 left = mod(left, right->op_type); 124281 if (right->op_type == OP_TRANS) 4873 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); else 119408 o = prepend_elem(right->op_type, scalar(left), right); 124281 if (type == OP_NOT) 11589 return newUNOP(OP_NOT, 0, scalar(o)); 112692 return o; } else 6106 return bind_match(type, left, pmruntime(newPMOP(OP_MATCH, 0), right, 0)); } OP * Perl_invert(pTHX_ OP *o) 22605 { 22605 if (!o) ###### return o; /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */ 22605 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); } OP * Perl_scope(pTHX_ OP *o) 443748 { dVAR; 443748 if (o) { 443748 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { 292800 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); 292800 o->op_type = OP_LEAVE; 292800 o->op_ppaddr = PL_ppaddr[OP_LEAVE]; } 150948 else if (o->op_type == OP_LINESEQ) { 149892 OP *kid; 149892 o->op_type = OP_SCOPE; 149892 o->op_ppaddr = PL_ppaddr[OP_SCOPE]; 149892 kid = ((LISTOP*)o)->op_first; 149892 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) 149892 op_null(kid); } else 1056 o = newLISTOP(OP_SCOPE, 0, o, Nullop); } 443748 return o; } /* XXX kept for BINCOMPAT only */ void Perl_save_hints(pTHX) ###### { ###### Perl_croak(aTHX_ "internal error: obsolete function save_hints() called"); } int Perl_block_start(pTHX_ int full) 1080196 { 1080196 const int retval = PL_savestack_ix; 1080196 pad_block_start(full); 1080196 SAVEHINTS(); 1080196 PL_hints &= ~HINT_BLOCK_SCOPE; 1080196 SAVESPTR(PL_compiling.cop_warnings); 1080196 if (! specialWARN(PL_compiling.cop_warnings)) { 14317 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; 14317 SAVEFREESV(PL_compiling.cop_warnings) ; } 1080196 SAVESPTR(PL_compiling.cop_io); 1080196 if (! specialCopIO(PL_compiling.cop_io)) { 3 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ; 3 SAVEFREESV(PL_compiling.cop_io) ; } 1080196 return retval; } OP* Perl_block_end(pTHX_ I32 floor, OP *seq) 1079382 { 1079382 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; 1079382 OP* retval = scalarseq(seq); 1079379 LEAVE_SCOPE(floor); 1079379 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 1079379 if (needblockscope) 754568 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ 1079379 pad_leavemy(); 1079379 return retval; } STATIC OP * S_newDEFSVOP(pTHX) 5878 { 5878 const I32 offset = pad_findmy("$_"); 5878 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { 5871 return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); } else { 7 OP *o = newOP(OP_PADSV, 0); 7 o->op_targ = offset; 7 return o; } } void Perl_newPROG(pTHX_ OP *o) 92813 { 92813 if (PL_in_eval) { 88965 if (PL_eval_root) ###### return; 88965 PL_eval_root = newUNOP(OP_LEAVEEVAL, ((PL_in_eval & EVAL_KEEPERR) ? OPf_SPECIAL : 0), o); 88964 PL_eval_start = linklist(PL_eval_root); 88964 PL_eval_root->op_private |= OPpREFCOUNTED; 88964 OpREFCNT_set(PL_eval_root, 1); 88964 PL_eval_root->op_next = 0; 88964 CALL_PEEP(PL_eval_start); } else { 3848 if (o->op_type == OP_STUB) { 51 PL_comppad_name = 0; 51 PL_compcv = 0; 51 FreeOp(o); 51 return; } 3797 PL_main_root = scope(sawparens(scalarvoid(o))); 3797 PL_curcop = &PL_compiling; 3797 PL_main_start = LINKLIST(PL_main_root); 3797 PL_main_root->op_private |= OPpREFCOUNTED; 3797 OpREFCNT_set(PL_main_root, 1); 3797 PL_main_root->op_next = 0; 3797 CALL_PEEP(PL_main_start); 3797 PL_compcv = 0; /* Register with debugger */ 3797 if (PERLDB_INTER) { 1 CV *cv = get_cv("DB::postponed", FALSE); 1 if (cv) { ###### dSP; ###### PUSHMARK(SP); ###### XPUSHs((SV*)CopFILEGV(&PL_compiling)); ###### PUTBACK; ###### call_sv((SV*)cv, G_DISCARD); } } } } OP * Perl_localize(pTHX_ OP *o, I32 lex) 491899 { 491899 if (o->op_flags & OPf_PARENS) /* [perl #17376]: this appears to be premature, and results in code such as C< our(%x); > executing in list mode rather than void mode */ #if 0 list(o); #else ; #endif else { 374026 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') { 388 char *s = PL_bufptr; 388 bool sigil = FALSE; /* some heuristics to detect a potential error */ 757 while (*s && (strchr(", \t\n", *s))) 369 s++; 644 while (1) { 644 if (*s && strchr("@$%*", *s) && *++s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) { 256 s++; 256 sigil = TRUE; 1023 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) 767 s++; 266 while (*s && (strchr(", \t\n", *s))) 10 s++; } else 388 break; } 388 if (sigil && (*s == ';' || *s == '=')) { 5 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), "Parentheses missing around \"%s\" list", lex ? (PL_in_my == KEY_our ? "our" : "my") : "local"); } } } 491899 if (lex) 454897 o = my(o); else 37002 o = mod(o, OP_NULL); /* a bit kludgey */ 491898 PL_in_my = FALSE; 491898 PL_in_my_stash = Nullhv; 491898 return o; } OP * Perl_jmaybe(pTHX_ OP *o) 363792 { 363792 if (o->op_type == OP_LIST) { 319 OP *o2; 319 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); } 363792 return o; } OP * Perl_fold_constants(pTHX_ register OP *o) 7844394 { dVAR; 7844394 register OP *curop; 7844394 I32 type = o->op_type; 7844394 SV *sv; 7844394 if (PL_opargs[type] & OA_RETSCALAR) 4212522 scalar(o); 7844394 if (PL_opargs[type] & OA_TARGET && !o->op_targ) 2902338 o->op_targ = pad_alloc(type, SVs_PADTMP); /* integerize op, unless it happens to be C<-foo>. * XXX should pp_i_negate() do magic string negation instead? */ 7844394 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER) && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST && (cUNOPo->op_first->op_private & OPpCONST_BARE))) { 7842 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)]; } 7844394 if (!(PL_opargs[type] & OA_FOLDCONST)) 6288381 goto nope; 1556013 switch (type) { case OP_NEGATE: /* XXX might want a ck_negate() for this */ 23444 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; 23444 break; case OP_SPRINTF: case OP_UCFIRST: case OP_LCFIRST: case OP_UC: case OP_LC: case OP_SLT: case OP_SGT: case OP_SLE: case OP_SGE: case OP_SCMP: /* XXX what about the numeric ops? */ 28437 if (PL_hints & HINT_LOCALE) 11157 goto nope; } 1544856 if (PL_error_count) 29 goto nope; /* Don't try to run w/ errors */ 3032026 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 2779119 if ((curop->op_type != OP_CONST || (curop->op_private & OPpCONST_BARE)) && curop->op_type != OP_LIST && curop->op_type != OP_SCALAR && curop->op_type != OP_NULL && curop->op_type != OP_PUSHMARK) { 1291920 goto nope; } } 252907 curop = LINKLIST(o); 252907 o->op_next = 0; 252907 PL_op = curop; 252907 CALLRUNOPS(aTHX); 252904 sv = *(PL_stack_sp--); 252904 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ 251054 pad_swipe(o->op_targ, FALSE); 1850 else if (SvTEMP(sv)) { /* grab mortal temp? */ 410 (void)SvREFCNT_inc(sv); 410 SvTEMP_off(sv); } 252904 op_free(o); 252904 if (type == OP_RV2GV) ###### return newGVOP(OP_GV, 0, (GV*)sv); 252904 return newSVOP(OP_CONST, 0, sv); nope: 7591487 return o; } OP * Perl_gen_constant_list(pTHX_ register OP *o) 1028 { dVAR; 1028 register OP *curop; 1028 const I32 oldtmps_floor = PL_tmps_floor; 1028 list(o); 1028 if (PL_error_count) ###### return o; /* Don't attempt to run with errors */ 1028 PL_op = curop = LINKLIST(o); 1028 o->op_next = 0; 1028 CALL_PEEP(curop); 1028 pp_pushmark(); 1028 CALLRUNOPS(aTHX); 1028 PL_op = curop; 1028 pp_anonlist(); 1028 PL_tmps_floor = oldtmps_floor; 1028 o->op_type = OP_RV2AV; 1028 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 1028 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ 1028 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ 1028 o->op_opt = 0; /* needs to be revisited in peep() */ 1028 curop = ((UNOP*)o)->op_first; 1028 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--)); 1028 op_free(curop); 1028 linklist(o); 1028 return list(o); } OP * Perl_convert(pTHX_ I32 type, I32 flags, OP *o) 1209235 { dVAR; 1209235 if (!o || o->op_type != OP_LIST) 689267 o = newLISTOP(OP_LIST, 0, o, Nullop); else 519968 o->op_flags &= ~OPf_WANT; 1209234 if (!(PL_opargs[type] & OA_MARK)) 547354 op_null(cLISTOPo->op_first); 1209234 o->op_type = (OPCODE)type; 1209234 o->op_ppaddr = PL_ppaddr[type]; 1209234 o->op_flags |= flags; 1209234 o = CHECKOP(type, o); 1209141 if (o->op_type != (unsigned)type) 22288 return o; 1186853 return fold_constants(o); } /* List constructors */ OP * Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) 2727098 { 2727098 if (!first) 108082 return last; 2619016 if (!last) 33052 return first; 2585964 if (first->op_type != (unsigned)type || (type == OP_LIST && (first->op_flags & OPf_PARENS))) { 880493 return newLISTOP(type, 0, first, last); } 1705471 if (first->op_flags & OPf_KIDS) 1705471 ((LISTOP*)first)->op_last->op_sibling = last; else { ###### first->op_flags |= OPf_KIDS; ###### ((LISTOP*)first)->op_first = last; } 1705471 ((LISTOP*)first)->op_last = last; 1705471 return first; } OP * Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) 2904907 { 2904907 if (!first) 818470 return (OP*)last; 2086437 if (!last) 611994 return (OP*)first; 1474443 if (first->op_type != (unsigned)type) 13157 return prepend_elem(type, (OP*)first, (OP*)last); 1461286 if (last->op_type != (unsigned)type) 56514 return append_elem(type, (OP*)first, (OP*)last); 1404772 first->op_last->op_sibling = last->op_first; 1404772 first->op_last = last->op_last; 1404772 first->op_flags |= (last->op_flags & OPf_KIDS); 1404772 FreeOp(last); 1404772 return (OP*)first; } OP * Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) 3128853 { 3128853 if (!first) ###### return last; 3128853 if (!last) 111202 return first; 3017651 if (last->op_type == (unsigned)type) { 544483 if (type == OP_LIST) { /* already a PUSHMARK there */ 54405 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; 54405 ((LISTOP*)last)->op_first->op_sibling = first; 54405 if (!(first->op_flags & OPf_PARENS)) 54350 last->op_flags &= ~OPf_PARENS; } else { 490078 if (!(last->op_flags & OPf_KIDS)) { 129368 ((LISTOP*)last)->op_last = first; 129368 last->op_flags |= OPf_KIDS; } 490078 first->op_sibling = ((LISTOP*)last)->op_first; 490078 ((LISTOP*)last)->op_first = first; } 544483 last->op_flags |= OPf_KIDS; 544483 return last; } 2473168 return newLISTOP(type, 0, first, last); } /* Constructors */ OP * Perl_newNULLLIST(pTHX) 18716 { 18716 return newOP(OP_STUB, 0); } OP * Perl_force_list(pTHX_ OP *o) 979900 { 979900 if (!o || o->op_type != OP_LIST) 602972 o = newLISTOP(OP_LIST, 0, o, Nullop); 979900 op_null(o); 979900 return o; } OP * Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 4660905 { dVAR; 4660905 LISTOP *listop; 4660905 NewOp(1101, listop, 1, LISTOP); 4660905 listop->op_type = (OPCODE)type; 4660905 listop->op_ppaddr = PL_ppaddr[type]; 4660905 if (first || last) 4632378 flags |= OPf_KIDS; 4660905 listop->op_flags = (U8)flags; 4660905 if (!last && first) 1264768 last = first; 3396137 else if (!first && last) ###### first = last; 3396137 else if (first) 3367610 first->op_sibling = last; 4660905 listop->op_first = first; 4660905 listop->op_last = last; 4660905 if (type == OP_LIST) { 2301385 OP* pushop; 2301385 pushop = newOP(OP_PUSHMARK, 0); 2301384 pushop->op_sibling = first; 2301384 listop->op_first = pushop; 2301384 listop->op_flags |= OPf_KIDS; 2301384 if (!last) 28527 listop->op_last = pushop; } 4660904 return CHECKOP(type, listop); } OP * Perl_newOP(pTHX_ I32 type, I32 flags) 5790078 { dVAR; 5790078 OP *o; 5790078 NewOp(1101, o, 1, OP); 5790078 o->op_type = (OPCODE)type; 5790078 o->op_ppaddr = PL_ppaddr[type]; 5790078 o->op_flags = (U8)flags; 5790078 o->op_next = o; 5790078 o->op_private = (U8)(0 | (flags >> 8)); 5790078 if (PL_opargs[type] & OA_RETSCALAR) 2535977 scalar(o); 5790078 if (PL_opargs[type] & OA_TARGET) 12429 o->op_targ = pad_alloc(type, SVs_PADTMP); 5790078 return CHECKOP(type, o); } OP * Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) 4502603 { dVAR; 4502603 UNOP *unop; 4502603 if (!first) ###### first = newOP(OP_STUB, 0); 4502603 if (PL_opargs[type] & OA_MARK) 495208 first = force_list(first); 4502603 NewOp(1101, unop, 1, UNOP); 4502603 unop->op_type = (OPCODE)type; 4502603 unop->op_ppaddr = PL_ppaddr[type]; 4502603 unop->op_first = first; 4502603 unop->op_flags = flags | OPf_KIDS; 4502603 unop->op_private = (U8)(1 | (flags >> 8)); 4502603 unop = (UNOP*) CHECKOP(type, unop); 4502532 if (unop->op_next) 215164 return (OP*)unop; 4287368 return fold_constants((OP *) unop); } OP * Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 2394951 { dVAR; 2394951 BINOP *binop; 2394951 NewOp(1101, binop, 1, BINOP); 2394951 if (!first) ###### first = newOP(OP_NULL, 0); 2394951 binop->op_type = (OPCODE)type; 2394951 binop->op_ppaddr = PL_ppaddr[type]; 2394951 binop->op_first = first; 2394951 binop->op_flags = flags | OPf_KIDS; 2394951 if (!last) { ###### last = first; ###### binop->op_private = (U8)(1 | (flags >> 8)); } else { 2394951 binop->op_private = (U8)(2 | (flags >> 8)); 2394951 first->op_sibling = last; } 2394951 binop = (BINOP*)CHECKOP(type, binop); 2394916 if (binop->op_next || binop->op_type != (OPCODE)type) 24828 return (OP*)binop; 2370088 binop->op_last = binop->op_first->op_sibling; 2370088 return fold_constants((OP *)binop); } static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__; static int uvcompare(const void *a, const void *b) 2050 { 2050 if (*((const UV *)a) < (*(const UV *)b)) 2050 return -1; ###### if (*((const UV *)a) > (*(const UV *)b)) ###### return 1; ###### if (*((const UV *)a+1) < (*(const UV *)b+1)) ###### return -1; ###### if (*((const UV *)a+1) > (*(const UV *)b+1)) ###### return 1; ###### return 0; } OP * Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 5123 { 5123 SV *tstr = ((SVOP*)expr)->op_sv; 5123 SV *rstr = ((SVOP*)repl)->op_sv; 5123 STRLEN tlen; 5123 STRLEN rlen; 5123 const U8 *t = (U8*)SvPV_const(tstr, tlen); 5123 const U8 *r = (U8*)SvPV_const(rstr, rlen); 5123 register I32 i; 5123 register I32 j; 5123 I32 del; 5123 I32 complement; 5123 I32 squash; 5123 I32 grows = 0; 5123 register short *tbl; 5123 PL_hints |= HINT_BLOCK_SCOPE; 5123 complement = o->op_private & OPpTRANS_COMPLEMENT; 5123 del = o->op_private & OPpTRANS_DELETE; 5123 squash = o->op_private & OPpTRANS_SQUASH; 5123 if (SvUTF8(tstr)) 42 o->op_private |= OPpTRANS_FROM_UTF; 5123 if (SvUTF8(rstr)) 43 o->op_private |= OPpTRANS_TO_UTF; 5123 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { 47 SV* listsv = newSVpvn("# comment\n",10); 47 SV* transv = 0; 47 const U8* tend = t + tlen; 47 const U8* rend = r + rlen; 47 STRLEN ulen; 47 UV tfirst = 1; 47 UV tlast = 0; 47 IV tdiff; 47 UV rfirst = 1; 47 UV rlast = 0; 47 IV rdiff; 47 IV diff; 47 I32 none = 0; 47 U32 max = 0; 47 I32 bits; 47 I32 havefinal = 0; 47 U32 final = 0; 47 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; 47 I32 to_utf = o->op_private & OPpTRANS_TO_UTF; 47 U8* tsave = NULL; 47 U8* rsave = NULL; 47 if (!from_utf) { 5 STRLEN len = tlen; 5 t = tsave = bytes_to_utf8(t, &len); 5 tend = t + len; } 47 if (!to_utf && rlen) { ###### STRLEN len = rlen; ###### r = rsave = bytes_to_utf8(r, &len); ###### rend = r + len; } /* There are several snags with this code on EBCDIC: 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes). 2. scan_const() in toke.c has encoded chars in native encoding which makes ranges at least in EBCDIC 0..255 range the bottom odd. */ 47 if (complement) { 8 U8 tmpbuf[UTF8_MAXBYTES+1]; 8 UV *cp; 8 UV nextmin = 0; 8 New(1109, cp, 2*tlen, UV); 8 i = 0; 8 transv = newSVpvn("",0); 528 while (t < tend) { 520 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0); 520 t += ulen; 520 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { 4 t++; 4 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0); 4 t += ulen; } else { 516 cp[2*i+1] = cp[2*i]; } 520 i++; } 8 qsort(cp, i, 2*sizeof(UV), uvcompare); 528 for (j = 0; j < i; j++) { 520 UV val = cp[2*j]; 520 diff = val - nextmin; 520 if (diff > 0) { 6 t = uvuni_to_utf8(tmpbuf,nextmin); 6 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 6 if (diff > 1) { 4 U8 range_mark = UTF_TO_NATIVE(0xff); 4 t = uvuni_to_utf8(tmpbuf, val - 1); 4 sv_catpvn(transv, (char *)&range_mark, 1); 4 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); } } 520 val = cp[2*j+1]; 520 if (val >= nextmin) 520 nextmin = val + 1; } 8 t = uvuni_to_utf8(tmpbuf,nextmin); 8 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); { 8 U8 range_mark = UTF_TO_NATIVE(0xff); 8 sv_catpvn(transv, (char *)&range_mark, 1); } 8 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff, UNICODE_ALLOW_SUPER); 8 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 8 t = (const U8*)SvPVX_const(transv); 8 tlen = SvCUR(transv); 8 tend = t + tlen; 8 Safefree(cp); } 39 else if (!rlen && !del) { ###### r = t; rlen = tlen; rend = tend; } 47 if (!squash) { 44 if ((!rlen && !del) || t == r || (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) { 4 o->op_private |= OPpTRANS_IDENTICAL; } } 141 while (t < tend || tfirst <= tlast) { /* see if we need more "t" chars */ 94 if (tfirst > tlast) { 89 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); 89 t += ulen; 89 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ 32 t++; 32 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); 32 t += ulen; } else 57 tlast = tfirst; } /* now see if we need more "r" chars */ 94 if (rfirst > rlast) { 86 if (r < rend) { 75 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); 75 r += ulen; 75 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ 20 r++; 20 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); 20 r += ulen; } else 55 rlast = rfirst; } else { 11 if (!havefinal++) 11 final = rlast; 11 rfirst = rlast = 0xffffffff; } } /* now see which range will peter our first, if either. */ 94 tdiff = tlast - tfirst; 94 rdiff = rlast - rfirst; 94 if (tdiff <= rdiff) 76 diff = tdiff; else 18 diff = rdiff; 94 if (rfirst == 0xffffffff) { 15 diff = tdiff; /* oops, pretend rdiff is infinite */ 15 if (diff > 0) 13 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n", (long)tfirst, (long)tlast); else 2 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst); } else { 79 if (diff > 0) 19 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n", (long)tfirst, (long)(tfirst + diff), (long)rfirst); else 60 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n", (long)tfirst, (long)rfirst); 79 if (rfirst + diff > max) 51 max = rfirst + diff; 79 if (!grows) 53 grows = (tfirst < rfirst && UNISKIP(tfirst) < UNISKIP(rfirst + diff)); 79 rfirst += diff + 1; } 94 tfirst += diff + 1; } 47 none = ++max; 47 if (del) 2 del = ++max; 47 if (max > 0xffff) ###### bits = 32; 47 else if (max > 0xff) 33 bits = 16; else 14 bits = 8; 47 Safefree(cPVOPo->op_pv); 47 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none); 47 SvREFCNT_dec(listsv); 47 if (transv) 8 SvREFCNT_dec(transv); 47 if (!del && havefinal && rlen) 7 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, newSVuv((UV)final), 0); 47 if (grows) 5 o->op_private |= OPpTRANS_GROWS; 47 if (tsave) 5 Safefree(tsave); 47 if (rsave) ###### Safefree(rsave); 47 op_free(expr); 47 op_free(repl); 47 return o; } 5076 tbl = (short*)cPVOPo->op_pv; 5076 if (complement) { 183 Zero(tbl, 256, short); 12555 for (i = 0; i < (I32)tlen; i++) 12372 tbl[t[i]] = -1; 47031 for (i = 0, j = 0; i < 256; i++) { 46848 if (!tbl[i]) { 34476 if (j >= (I32)rlen) { 34476 if (del) 29765 tbl[i] = -2; 4711 else if (rlen) ###### tbl[i] = r[j-1]; else 4711 tbl[i] = (short)i; } else { ###### if (i < 128 && r[j] >= 128) ###### grows = 1; ###### tbl[i] = r[j++]; } } } 183 if (!del) { 33 if (!rlen) { 29 j = rlen; 29 if (!squash) 26 o->op_private |= OPpTRANS_IDENTICAL; } 4 else if (j >= (I32)rlen) ###### j = rlen - 1; else 4 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short); 33 tbl[0x100] = rlen - j; 39 for (i=0; i < (I32)rlen - j; i++) 6 tbl[0x101+i] = r[j+i]; } } else { 4893 if (!rlen && !del) { 1923 r = t; rlen = tlen; 1923 if (!squash) 1923 o->op_private |= OPpTRANS_IDENTICAL; } 2970 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) { 47 o->op_private |= OPpTRANS_IDENTICAL; } 1257501 for (i = 0; i < 256; i++) 1252608 tbl[i] = -1; 111596 for (i = 0, j = 0; i < (I32)tlen; i++,j++) { 106703 if (j >= (I32)rlen) { 20276 if (del) { 13577 if (tbl[t[i]] == -1) 12865 tbl[t[i]] = -2; 12865 continue; } 6699 --j; } 93126 if (tbl[t[i]] == -1) { 93122 if (t[i] < 128 && r[j] >= 128) 2826 grows = 1; 93122 tbl[t[i]] = r[j]; } } } 5076 if (grows) 32 o->op_private |= OPpTRANS_GROWS; 5076 op_free(expr); 5076 op_free(repl); 5076 return o; } OP * Perl_newPMOP(pTHX_ I32 type, I32 flags) 160257 { dVAR; 160257 PMOP *pmop; 160257 NewOp(1101, pmop, 1, PMOP); 160257 pmop->op_type = (OPCODE)type; 160257 pmop->op_ppaddr = PL_ppaddr[type]; 160257 pmop->op_flags = (U8)flags; 160257 pmop->op_private = (U8)(0 | (flags >> 8)); 160257 if (PL_hints & HINT_RE_TAINT) 9748 pmop->op_pmpermflags |= PMf_RETAINT; 160257 if (PL_hints & HINT_LOCALE) 504 pmop->op_pmpermflags |= PMf_LOCALE; 160257 pmop->op_pmflags = pmop->op_pmpermflags; #ifdef USE_ITHREADS { SV* repointer; if(av_len((AV*) PL_regex_pad[0]) > -1) { repointer = av_pop((AV*)PL_regex_pad[0]); pmop->op_pmoffset = SvIV(repointer); SvREPADTMP_off(repointer); sv_setiv(repointer,0); } else { repointer = newSViv(0); av_push(PL_regex_padav,SvREFCNT_inc(repointer)); pmop->op_pmoffset = av_len(PL_regex_padav); PL_regex_pad = AvARRAY(PL_regex_padav); } } #endif /* link into pm list */ 160257 if (type != OP_TRANS && PL_curstash) { 160257 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab); 160257 if (!mg) { 15488 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0); } 160257 pmop->op_pmnext = (PMOP*)mg->mg_obj; 160257 mg->mg_obj = (SV*)pmop; 160257 PmopSTASH_set(pmop,PL_curstash); } 160257 return CHECKOP(type, pmop); } /* Given some sort of match op o, and an expression expr containing a * pattern, either compile expr into a regex and attach it to o (if it's * constant), or convert expr into a runtime regcomp op sequence (if it's * not) * * isreg indicates that the pattern is part of a regex construct, eg * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or * split "pattern", which aren't. In the former case, expr will be a list * if the pattern contains more than one term (eg /a$b/) or if it contains * a replacement, ie s/// or tr///. */ OP * Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) 165375 { dVAR; 165375 PMOP *pm; 165375 LOGOP *rcop; 165375 I32 repl_has_vars = 0; 165375 OP* repl = Nullop; 165375 bool reglist; 165375 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) { /* last element in list is the replacement; pop it */ 58242 OP* kid; 58242 repl = cLISTOPx(expr)->op_last; 58242 kid = cLISTOPx(expr)->op_first; 122881 while (kid->op_sibling != repl) 64639 kid = kid->op_sibling; 58242 kid->op_sibling = Nullop; 58242 cLISTOPx(expr)->op_last = kid; } 165375 if (isreg && expr->op_type == OP_LIST && cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last) { /* convert single element list to element */ 55366 OP* oe = expr; 55366 expr = cLISTOPx(oe)->op_first->op_sibling; 55366 cLISTOPx(oe)->op_first->op_sibling = Nullop; 55366 cLISTOPx(oe)->op_last = Nullop; 55366 op_free(oe); } 165375 if (o->op_type == OP_TRANS) { 5123 return pmtrans(o, expr, repl); } 160252 reglist = isreg && expr->op_type == OP_LIST; 160252 if (reglist) 9158 op_null(expr); 160252 PL_hints |= HINT_BLOCK_SCOPE; 160252 pm = (PMOP*)o; 160252 if (expr->op_type == OP_CONST) { 140591 STRLEN plen; 140591 SV *pat = ((SVOP*)expr)->op_sv; 140591 const char *p = SvPV_const(pat, plen); 140591 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { 918 U32 was_readonly = SvREADONLY(pat); 918 if (was_readonly) { 918 if (SvFAKE(pat)) { ###### sv_force_normal_flags(pat, 0); ###### assert(!SvREADONLY(pat)); ###### was_readonly = 0; } else { 918 SvREADONLY_off(pat); } } 918 sv_setpvn(pat, "\\s+", 3); 918 SvFLAGS(pat) |= was_readonly; 918 p = SvPV_const(pat, plen); 918 pm->op_pmflags |= PMf_SKIPWHITE; } 140591 if (DO_UTF8(pat)) 45 pm->op_pmdynflags |= PMdf_UTF8; /* FIXME - can we make this function take const char * args? */ 140591 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm)); 140360 if (strEQ("\\s+", PM_GETRE(pm)->precomp)) 1790 pm->op_pmflags |= PMf_WHITE; 140360 op_free(expr); } else { 19661 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) 19640 expr = newUNOP((!(PL_hints & HINT_RE_EVAL) ? OP_REGCRESET : OP_REGCMAYBE),0,expr); 19661 NewOp(1101, rcop, 1, LOGOP); 19661 rcop->op_type = OP_REGCOMP; 19661 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; 19661 rcop->op_first = scalar(expr); 19661 rcop->op_flags |= OPf_KIDS | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) | (reglist ? OPf_STACKED : 0); 19661 rcop->op_private = 1; 19661 rcop->op_other = o; 19661 if (reglist) 9158 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP); /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ 19661 PL_cv_has_eval = 1; /* establish postfix order */ 19661 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) { 19640 LINKLIST(expr); 19640 rcop->op_next = expr; 19640 ((UNOP*)expr)->op_first->op_next = (OP*)rcop; } else { 21 rcop->op_next = LINKLIST(expr); 21 expr->op_next = (OP*)rcop; } 19661 prepend_elem(o->op_type, scalar((OP*)rcop), o); } 160021 if (repl) { 53119 OP *curop; 53119 if (pm->op_pmflags & PMf_EVAL) { 3674 curop = 0; 3674 if (CopLINE(PL_curcop) < (line_t)PL_multi_end) 2 CopLINE_set(PL_curcop, (line_t)PL_multi_end); } 49445 else if (repl->op_type == OP_CONST) 40643 curop = repl; else { 8802 OP *lastop = 0; 14395 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { 13342 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 9419 if (curop->op_type == OP_GV) { 7677 GV *gv = cGVOPx_gv(curop); 7677 repl_has_vars = 1; 7677 if (strchr("&`'123456789+-\016\022", *GvENAME(gv))) 7453 break; } 1742 else if (curop->op_type == OP_RV2CV) ###### break; 1742 else if (curop->op_type == OP_RV2SV || curop->op_type == OP_RV2AV || curop->op_type == OP_RV2HV || curop->op_type == OP_RV2GV) { 438 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/ 296 break; } 1304 else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || curop->op_type == OP_PADANY) { 1304 repl_has_vars = 1; } ###### else if (curop->op_type == OP_PUSHRE) ; /* Okay here, dangerous in newASSIGNOP */ else 5593 break; } 5593 lastop = curop; } } 53119 if (curop == repl && !(repl_has_vars && (!PM_GETRE(pm) || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) { 41531 pm->op_pmflags |= PMf_CONST; /* const for long enough */ 41531 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ 41531 prepend_elem(o->op_type, scalar(repl), o); } else { 11588 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */ 163 pm->op_pmflags |= PMf_MAYBE_CONST; 163 pm->op_pmpermflags |= PMf_MAYBE_CONST; } 11588 NewOp(1101, rcop, 1, LOGOP); 11588 rcop->op_type = OP_SUBSTCONT; 11588 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT]; 11588 rcop->op_first = scalar(repl); 11588 rcop->op_flags |= OPf_KIDS; 11588 rcop->op_private = 1; 11588 rcop->op_other = o; /* establish postfix order */ 11588 rcop->op_next = LINKLIST(repl); 11588 repl->op_next = (OP*)rcop; 11588 pm->op_pmreplroot = scalar((OP*)rcop); 11588 pm->op_pmreplstart = LINKLIST(rcop); 11588 rcop->op_next = 0; } } 160021 return (OP*)pm; } OP * Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) 5792867 { dVAR; 5792867 SVOP *svop; 5792867 NewOp(1101, svop, 1, SVOP); 5792867 svop->op_type = (OPCODE)type; 5792867 svop->op_ppaddr = PL_ppaddr[type]; 5792867 svop->op_sv = sv; 5792867 svop->op_next = (OP*)svop; 5792867 svop->op_flags = (U8)flags; 5792867 if (PL_opargs[type] & OA_RETSCALAR) 5522452 scalar((OP*)svop); 5792867 if (PL_opargs[type] & OA_TARGET) 514 svop->op_targ = pad_alloc(type, SVs_PADTMP); 5792867 return CHECKOP(type, svop); } OP * Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) ###### { dVAR; ###### PADOP *padop; ###### NewOp(1101, padop, 1, PADOP); ###### padop->op_type = (OPCODE)type; ###### padop->op_ppaddr = PL_ppaddr[type]; ###### padop->op_padix = pad_alloc(type, SVs_PADTMP); ###### SvREFCNT_dec(PAD_SVl(padop->op_padix)); ###### PAD_SETSV(padop->op_padix, sv); ###### if (sv) ###### SvPADTMP_on(sv); ###### padop->op_next = (OP*)padop; ###### padop->op_flags = (U8)flags; ###### if (PL_opargs[type] & OA_RETSCALAR) ###### scalar((OP*)padop); ###### if (PL_opargs[type] & OA_TARGET) ###### padop->op_targ = pad_alloc(type, SVs_PADTMP); ###### return CHECKOP(type, padop); } OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) 155387 { dVAR; #ifdef USE_ITHREADS if (gv) GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc(gv)); #else 155387 return newSVOP(type, flags, SvREFCNT_inc(gv)); #endif } OP * Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) 13330 { dVAR; 13330 PVOP *pvop; 13330 NewOp(1101, pvop, 1, PVOP); 13330 pvop->op_type = (OPCODE)type; 13330 pvop->op_ppaddr = PL_ppaddr[type]; 13330 pvop->op_pv = pv; 13330 pvop->op_next = (OP*)pvop; 13330 pvop->op_flags = (U8)flags; 13330 if (PL_opargs[type] & OA_RETSCALAR) 13330 scalar((OP*)pvop); 13330 if (PL_opargs[type] & OA_TARGET) ###### pvop->op_targ = pad_alloc(type, SVs_PADTMP); 13330 return CHECKOP(type, pvop); } void Perl_package(pTHX_ OP *o) 28674 { 28674 const char *name; 28674 STRLEN len; 28674 save_hptr(&PL_curstash); 28674 save_item(PL_curstname); 28674 name = SvPV_const(cSVOPo->op_sv, len); 28674 PL_curstash = gv_stashpvn(name, len, TRUE); 28674 sv_setpvn(PL_curstname, name, len); 28674 op_free(o); 28674 PL_hints |= HINT_BLOCK_SCOPE; 28674 PL_copline = NOLINE; 28674 PL_expect = XSTATE; } void Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) 49806 { 49806 OP *pack; 49806 OP *imop; 49806 OP *veop; 49806 if (idop->op_type != OP_CONST) ###### Perl_croak(aTHX_ "Module name must be constant"); 49806 veop = Nullop; 49806 if (version != Nullop) { 196 SV *vesv = ((SVOP*)version)->op_sv; 196 if (arg == Nullop && !SvNIOKp(vesv)) { ###### arg = version; } else { 196 OP *pack; 196 SV *meth; 196 if (version->op_type != OP_CONST || !SvNIOKp(vesv)) ###### Perl_croak(aTHX_ "Version number must be constant number"); /* Make copy of idop so we don't free it twice */ 196 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to VERSION */ 196 meth = newSVpvn_share("VERSION", 7, 0); 196 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(version)), newSVOP(OP_METHOD_NAMED, 0, meth))); } } /* Fake up an import/unimport */ 49806 if (arg && arg->op_type == OP_STUB) 2407 imop = arg; /* no import on explicit () */ 47399 else if (SvNIOKp(((SVOP*)idop)->op_sv)) { 4137 imop = Nullop; /* use 5.0; */ } else { 43262 SV *meth; /* Make copy of idop so we don't free it twice */ 43262 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to import/unimport */ 43262 meth = aver ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0); 43262 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(arg)), newSVOP(OP_METHOD_NAMED, 0, meth))); } /* Fake up the BEGIN {}, which does its thing immediately. */ 49806 newATTRSUB(floor, newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)), Nullop, Nullop, append_elem(OP_LINESEQ, append_elem(OP_LINESEQ, newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)), newSTATEOP(0, Nullch, veop)), newSTATEOP(0, Nullch, imop) )); /* The "did you use incorrect case?" warning used to be here. * The problem is that on case-insensitive filesystems one * might get false positives for "use" (and "require"): * "use Strict" or "require CARP" will work. This causes * portability problems for the script: in case-strict * filesystems the script will stop working. * * The "incorrect case" warning checked whether "use Foo" * imported "Foo" to your namespace, but that is wrong, too: * there is no requirement nor promise in the language that * a Foo.pm should or would contain anything in package "Foo". * * There is very little Configure-wise that can be done, either: * the case-sensitivity of the build filesystem of Perl does not * help in guessing the case-sensitivity of the runtime environment. */ 49671 PL_hints |= HINT_BLOCK_SCOPE; 49671 PL_copline = NOLINE; 49671 PL_expect = XSTATE; 49671 PL_cop_seqmax++; /* Purely for B::*'s benefit */ } /* =head1 Embedding Functions =for apidoc load_module Loads the module whose name is pointed to by the string part of name. Note that the actual module name, not its filename, should be given. Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS (or 0 for no flags). ver, if specified, provides version semantics similar to C. The optional trailing SV* arguments can be used to specify arguments to the module's import() method, similar to C. =cut */ void Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) 365 { 365 va_list args; 365 va_start(args, ver); 365 vload_module(flags, name, ver, &args); va_end(args); } #ifdef PERL_IMPLICIT_CONTEXT void Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) { dTHX; va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif void Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) 365 { 365 OP *modname, *veop, *imop; 365 modname = newSVOP(OP_CONST, 0, name); 365 modname->op_private |= OPpCONST_BARE; 365 if (ver) { 66 veop = newSVOP(OP_CONST, 0, ver); } else 299 veop = Nullop; 365 if (flags & PERL_LOADMOD_NOIMPORT) { 299 imop = sawparens(newNULLLIST()); } 66 else if (flags & PERL_LOADMOD_IMPORT_OPS) { 33 imop = va_arg(*args, OP*); } else { 33 SV *sv; 33 imop = Nullop; 33 sv = va_arg(*args, SV*); 66 while (sv) { 33 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); 33 sv = va_arg(*args, SV*); } } { 365 const line_t ocopline = PL_copline; 365 COP * const ocurcop = PL_curcop; 365 const int oexpect = PL_expect; 365 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); 358 PL_expect = oexpect; 358 PL_copline = ocopline; 358 PL_curcop = ocurcop; } } OP * Perl_dofile(pTHX_ OP *term) 757 { 757 OP *doop; 757 GV *gv; 757 gv = gv_fetchpv("do", FALSE, SVt_PVCV); 757 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) 757 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV); 757 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { ###### doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, term, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv)))))); } else { 757 doop = newUNOP(OP_DOFILE, 0, scalar(term)); } 756 return doop; } OP * Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) 17281 { 17281 return newBINOP(OP_LSLICE, flags, list(force_list(subscript)), list(force_list(listval)) ); } STATIC I32 S_is_list_assignment(pTHX_ register const OP *o) 879074 { 879074 if (!o) ###### return TRUE; 879074 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS) 231 o = cUNOPo->op_first; 879074 if (o->op_type == OP_COND_EXPR) { 231 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); 231 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); 231 if (t && f) ###### return TRUE; 231 if (t || f) ###### yyerror("Assignment to both a list and a scalar"); 231 return FALSE; } 878843 if (o->op_type == OP_LIST && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR && o->op_private & OPpLVAL_INTRO) 1 return FALSE; 878842 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS || o->op_type == OP_RV2AV || o->op_type == OP_RV2HV || o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) 159779 return TRUE; 719063 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) 43066 return TRUE; 675997 if (o->op_type == OP_RV2SV) 132089 return FALSE; 543908 return FALSE; } OP * Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) 966575 { 966575 OP *o; 966575 if (optype) { 87963 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { 15720 return newLOGOP(optype, 0, mod(scalar(left), optype), newUNOP(OP_SASSIGN, 0, scalar(right))); } else { 72243 return newBINOP(optype, OPf_STACKED, mod(scalar(left), optype), scalar(right)); } } 878612 if (is_list_assignment(left)) { 202845 OP *curop; 202845 PL_modcount = 0; /* Grandfathering $[ assignment here. Bletch.*/ /* Only simple assignments like C<< ($[) = 1 >> are allowed */ 202845 PL_eval_start = (left->op_type == OP_CONST) ? right : 0; 202845 left = mod(left, OP_AASSIGN); 202842 if (PL_eval_start) ###### PL_eval_start = 0; 202842 else if (left->op_type == OP_CONST) { /* Result of assignment is always 1 (or we'd be dead already) */ 2 return newSVOP(OP_CONST, 0, newSViv(1)); } /* optimise C to C, and likewise for hashes */ 202840 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV) && right->op_type == OP_STUB && (left->op_private & OPpLVAL_INTRO)) { 3104 op_free(right); 3104 left->op_flags &= ~(OPf_REF|OPf_SPECIAL); 3104 return left; } 199736 curop = list(force_list(left)); 199736 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); 199735 o->op_private = (U8)(0 | (flags >> 8)); /* PL_generation sorcery: * an assignment like ($a,$b) = ($c,$d) is easier than * ($a,$b) = ($c,$a), since there is no need for temporary vars. * To detect whether there are common vars, the global var * PL_generation is incremented for each assign op we compile. * Then, while compiling the assign op, we run through all the * variables on both sides of the assignment, setting a spare slot * in each of them to PL_generation. If any of them already have * that value, we know we've got commonality. We could use a * single bit marker, but then we'd have to make 2 passes, first * to clear the flag, then to test and set it. To find somewhere * to store these values, evil chicanery is done with SvCUR(). */ 199735 if (!(left->op_private & OPpLVAL_INTRO)) { 81945 OP *lastop = o; 81945 PL_generation++; 1416950 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 1371447 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 180518 if (curop->op_type == OP_GV) { 53012 GV *gv = cGVOPx_gv(curop); 53012 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) 45956 break; 45956 SvCUR_set(gv, PL_generation); } 127506 else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || curop->op_type == OP_PADANY) { 57295 if (PAD_COMPNAME_GEN(curop->op_targ) == (STRLEN)PL_generation) 2579 break; 54716 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation); } 70211 else if (curop->op_type == OP_RV2CV) 38 break; 70173 else if (curop->op_type == OP_RV2SV || curop->op_type == OP_RV2AV || curop->op_type == OP_RV2HV || curop->op_type == OP_RV2GV) { 55894 if (lastop->op_type != OP_GV) /* funny deref? */ 13119 break; } 14279 else if (curop->op_type == OP_PUSHRE) { 629 if (((PMOP*)curop)->op_pmreplroot) { #ifdef USE_ITHREADS GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET, ((PMOP*)curop)->op_pmreplroot)); #else 1 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; #endif 1 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) 1 break; 1 SvCUR_set(gv, PL_generation); } } else 1335005 break; } 1335005 lastop = curop; } 81945 if (curop != o) 36442 o->op_private |= OPpASSIGN_COMMON; } 199735 if (right && right->op_type == OP_SPLIT) { 4058 OP* tmpop; 4058 if ((tmpop = ((LISTOP*)right)->op_first) && tmpop->op_type == OP_PUSHRE) { 4058 PMOP *pm = (PMOP*)tmpop; 4058 if (left->op_type == OP_RV2AV && !(left->op_private & OPpLVAL_INTRO) && !(o->op_private & OPpASSIGN_COMMON) ) { 75 tmpop = ((UNOP*)left)->op_first; 75 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) { #ifdef USE_ITHREADS pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix); cPADOPx(tmpop)->op_padix = 0; /* steal it */ #else 74 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv; 74 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */ #endif 74 pm->op_pmflags |= PMf_ONCE; 74 tmpop = cUNOPo->op_first; /* to list (nulled) */ 74 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ 74 tmpop->op_sibling = Nullop; /* don't free split */ 74 right->op_next = tmpop->op_next; /* fix starting loc */ 74 op_free(o); /* blow off assign */ 74 right->op_flags &= ~OPf_WANT; /* "I don't know and I don't care." */ 74 return right; } } else { 3983 if (PL_modcount < RETURN_UNLIMITED_NUMBER && ((LISTOP*)right)->op_last->op_type == OP_CONST) { 592 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; 592 if (SvIVX(sv) == 0) 295 sv_setiv(sv, PL_modcount+1); } } } } 199661 return o; } 675767 if (!right) ###### right = newOP(OP_UNDEF, 0); 675767 if (right->op_type == OP_READLINE) { 2853 right->op_flags |= OPf_STACKED; 2853 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right)); } else { 672914 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ 672914 o = newBINOP(OP_SASSIGN, flags, scalar(right), mod(scalar(left), OP_SASSIGN) ); 672913 if (PL_eval_start) 672901 PL_eval_start = 0; else { 12 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase)); } } 672913 return o; } OP * Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) 2375353 { dVAR; 2375353 const U32 seq = intro_my(); 2375353 register COP *cop; 2375353 NewOp(1101, cop, 1, COP); 2375353 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) { 402 cop->op_type = OP_DBSTATE; 402 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ]; } else { 2374951 cop->op_type = OP_NEXTSTATE; 2374951 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; } 2375353 cop->op_flags = (U8)flags; 2375353 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif 2375353 PL_compiling.op_private = cop->op_private; 2375353 cop->op_next = (OP*)cop; 2375353 if (label) { 4297 cop->cop_label = label; 4297 PL_hints |= HINT_BLOCK_SCOPE; } 2375353 cop->cop_seq = seq; 2375353 cop->cop_arybase = PL_curcop->cop_arybase; 2375353 if (specialWARN(PL_curcop->cop_warnings)) 2340500 cop->cop_warnings = PL_curcop->cop_warnings ; else 34853 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ; 2375353 if (specialCopIO(PL_curcop->cop_io)) 2375327 cop->cop_io = PL_curcop->cop_io; else 26 cop->cop_io = newSVsv(PL_curcop->cop_io) ; 2375353 if (PL_copline == NOLINE) 114904 CopLINE_set(cop, CopLINE(PL_curcop)); else { 2260449 CopLINE_set(cop, PL_copline); 2260449 PL_copline = NOLINE; } #ifdef USE_ITHREADS CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ #else 2375353 CopFILEGV_set(cop, CopFILEGV(PL_curcop)); #endif 2375353 CopSTASH_set(cop, PL_curstash); 2375353 if (PERLDB_LINE && PL_curstash != PL_debstash) { 429 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE); 429 if (svp && *svp != &PL_sv_undef ) { 429 (void)SvIOK_on(*svp); 429 SvIV_set(*svp, PTR2IV(cop)); } } 2375353 return prepend_elem(OP_LINESEQ, (OP*)cop, o); } OP * Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) 567573 { dVAR; 567573 return new_logop(type, flags, &first, &other); } STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) 649993 { dVAR; 649993 LOGOP *logop; 649993 OP *o; 649993 OP *first = *firstp; 649993 OP *other = *otherp; 649993 if (type == OP_XOR) /* Not short circuit, but here by precedence. */ 1192 return newBINOP(type, flags, scalar(first), scalar(other)); 648801 scalarboolean(first); /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ 648801 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) { 21772 if (type == OP_AND || type == OP_OR) { 21772 if (type == OP_AND) 21772 type = OP_OR; else ###### type = OP_AND; 21772 o = first; 21772 first = *firstp = cUNOPo->op_first; 21772 if (o->op_next) 21772 first->op_next = o->op_next; 21772 cUNOPo->op_first = Nullop; 21772 op_free(o); } } 648801 if (first->op_type == OP_CONST) { 4446 if (first->op_private & OPpCONST_STRICT) 2 no_bareword_allowed(first); 4444 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) 1 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); 4446 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) || 57 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) || (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) { 1447 op_free(first); 1447 *firstp = Nullop; 1447 if (other->op_type == OP_CONST) 9 other->op_private |= OPpCONST_SHORTCIRCUIT; 1447 return other; } else { /* check for C, or C */ 2999 const OP *o2 = other; 2999 if ( ! (o2->op_type == OP_LIST && (( o2 = cUNOPx(o2)->op_first)) && o2->op_type == OP_PUSHMARK && (( o2 = o2->op_sibling)) ) ) 2998 o2 = other; 2999 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV || o2->op_type == OP_PADHV) && o2->op_private & OPpLVAL_INTRO && ckWARN(WARN_DEPRECATED)) { 7 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Deprecated use of my() in false conditional"); } 2999 op_free(other); 2999 *otherp = Nullop; 2999 if (first->op_type == OP_CONST) 2999 first->op_private |= OPpCONST_SHORTCIRCUIT; 2999 return first; } } 644355 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) && type != OP_DOR) /* [#24076] Don't warn for err FOO. */ { 247384 const OP *k1 = ((UNOP*)first)->op_first; 247384 const OP *k2 = k1->op_sibling; 247384 OPCODE warnop = 0; 247384 switch (first->op_type) { case OP_NULL: 52482 if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) { 1 warnop = k2->op_type; } 1 break; case OP_SASSIGN: 4239 if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH) { 5 warnop = ((k1->op_type == OP_NULL) ? (OPCODE)k1->op_targ : k1->op_type); } break; } 247384 if (warnop) { 6 const line_t oldline = CopLINE(PL_curcop); 6 CopLINE_set(PL_curcop, PL_copline); 6 Perl_warner(aTHX_ packWARN(WARN_MISC), "Value of %s%s can be \"0\"; test with defined()", PL_op_desc[warnop], ((warnop == OP_READLINE || warnop == OP_GLOB) ? " construct" : "() operator")); 6 CopLINE_set(PL_curcop, oldline); } } 644355 if (!other) ###### return first; 644355 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) 15720 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ 644355 NewOp(1101, logop, 1, LOGOP); 644355 logop->op_type = (OPCODE)type; 644355 logop->op_ppaddr = PL_ppaddr[type]; 644355 logop->op_first = first; 644355 logop->op_flags = flags | OPf_KIDS; 644355 logop->op_other = LINKLIST(other); 644355 logop->op_private = (U8)(1 | (flags >> 8)); /* establish postfix order */ 644355 logop->op_next = LINKLIST(first); 644355 first->op_next = (OP*)logop; 644355 first->op_sibling = other; 644355 CHECKOP(type,logop); 644349 o = newUNOP(OP_NULL, 0, (OP*)logop); 644349 other->op_next = o; 644349 return o; } OP * Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) 324804 { dVAR; 324804 LOGOP *logop; 324804 OP *start; 324804 OP *o; 324804 if (!falseop) 135103 return newLOGOP(OP_AND, 0, first, trueop); 189701 if (!trueop) ###### return newLOGOP(OP_OR, 0, first, falseop); 189701 scalarboolean(first); 189701 if (first->op_type == OP_CONST) { 327 if (first->op_private & OPpCONST_BARE && first->op_private & OPpCONST_STRICT) { 1 no_bareword_allowed(first); } 327 if (SvTRUE(((SVOP*)first)->op_sv)) { 259 op_free(first); 259 op_free(falseop); 259 return trueop; } else { 68 op_free(first); 68 op_free(trueop); 68 return falseop; } } 189374 NewOp(1101, logop, 1, LOGOP); 189374 logop->op_type = OP_COND_EXPR; 189374 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; 189374 logop->op_first = first; 189374 logop->op_flags = flags | OPf_KIDS; 189374 logop->op_private = (U8)(1 | (flags >> 8)); 189374 logop->op_other = LINKLIST(trueop); 189374 logop->op_next = LINKLIST(falseop); CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ 189374 logop); /* establish postfix order */ 189373 start = LINKLIST(first); 189373 first->op_next = (OP*)logop; 189373 first->op_sibling = trueop; 189373 trueop->op_sibling = falseop; 189373 o = newUNOP(OP_NULL, 0, (OP*)logop); 189373 trueop->op_next = falseop->op_next = o; 189373 o->op_next = start; 189373 return o; } OP * Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) 6051 { dVAR; 6051 LOGOP *range; 6051 OP *flip; 6051 OP *flop; 6051 OP *leftstart; 6051 OP *o; 6051 NewOp(1101, range, 1, LOGOP); 6051 range->op_type = OP_RANGE; 6051 range->op_ppaddr = PL_ppaddr[OP_RANGE]; 6051 range->op_first = left; 6051 range->op_flags = OPf_KIDS; 6051 leftstart = LINKLIST(left); 6051 range->op_other = LINKLIST(right); 6051 range->op_private = (U8)(1 | (flags >> 8)); 6051 left->op_sibling = right; 6051 range->op_next = (OP*)range; 6051 flip = newUNOP(OP_FLIP, flags, (OP*)range); 6050 flop = newUNOP(OP_FLOP, 0, flip); 6049 o = newUNOP(OP_NULL, 0, flop); 6049 linklist(flop); 6049 range->op_next = leftstart; 6049 left->op_next = flip; 6049 right->op_next = flop; 6049 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 6049 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); 6049 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 6049 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); 6049 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 6049 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 6049 flip->op_next = o; 6049 if (!flip->op_private || !flop->op_private) 4485 linklist(o); /* blow off optimizer unless constant */ 6049 return o; } OP * Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) 12822 { 12822 OP* listop; 12822 OP* o; 12822 const bool once = block && block->op_flags & OPf_SPECIAL && 12822 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); 12822 (void)debuggable; 12822 if (expr) { 12822 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) ###### return block; /* do {} while 0 does once */ 12822 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { 142 expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 12680 } else if (expr->op_flags & OPf_KIDS) { 12495 const OP *k1 = ((UNOP*)expr)->op_first; 12495 const OP *k2 = (k1) ? k1->op_sibling : NULL; 12495 switch (expr->op_type) { case OP_NULL: 575 if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 2 expr = newUNOP(OP_DEFINED, 0, expr); 2 break; case OP_SASSIGN: 38 if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH) 7 expr = newUNOP(OP_DEFINED, 0, expr); break; } } } /* if block is null, the next append_elem() would put UNSTACK, a scalar * op, in listop. This is wrong. [perl #27024] */ 12822 if (!block) ###### block = newOP(OP_NULL, 0); 12822 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); 12822 o = new_logop(OP_AND, 0, &expr, &listop); 12822 if (listop) 12822 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); 12822 if (once && o != listop) 940 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; 12822 if (o == listop) ###### o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ 12822 o->op_flags |= flags; 12822 o = scope(o); 12822 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ 12822 return o; } OP * Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont, I32 has_my) 81259 { dVAR; 81259 OP *redo; 81259 OP *next = 0; 81259 OP *listop; 81259 OP *o; 81259 U8 loopflags = 0; 81259 (void)debuggable; 81259 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { 1128 expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 80131 } else if (expr && (expr->op_flags & OPf_KIDS)) { 15357 const OP *k1 = ((UNOP*)expr)->op_first; 15357 const OP *k2 = (k1) ? k1->op_sibling : NULL; 15357 switch (expr->op_type) { case OP_NULL: 3832 if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 151 expr = newUNOP(OP_DEFINED, 0, expr); 151 break; case OP_SASSIGN: 518 if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH) 12 expr = newUNOP(OP_DEFINED, 0, expr); break; } } 81259 if (!block) ###### block = newOP(OP_NULL, 0); 81259 else if (cont || has_my) { 4916 block = scope(block); } 81259 if (cont) { 3619 next = LINKLIST(cont); } 81259 if (expr) { 69599 OP *unstack = newOP(OP_UNSTACK, 0); 69598 if (!next) 65991 next = unstack; 69598 cont = append_elem(OP_LINESEQ, cont, unstack); } 81258 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont); 81258 redo = LINKLIST(listop); 81258 if (expr) { 69598 PL_copline = (line_t)whileline; 69598 scalar(listop); 69598 o = new_logop(OP_AND, 0, &expr, &listop); 69598 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { 2 op_free(expr); /* oops, it's a while (0) */ 2 op_free((OP*)loop); 2 return Nullop; /* listop already freed by new_logop */ } 69596 if (listop) 69596 ((LISTOP*)listop)->op_last->op_next = (o == listop ? redo : LINKLIST(o)); } else 11660 o = listop; 81256 if (!loop) { 30167 NewOp(1101,loop,1,LOOP); 30167 loop->op_type = OP_ENTERLOOP; 30167 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP]; 30167 loop->op_private = 0; 30167 loop->op_next = (OP*)loop; } 81256 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o); 81256 loop->op_redoop = redo; 81256 loop->op_lastop = o; 81256 o->op_private |= loopflags; 81256 if (next) 69608 loop->op_nextop = next; else 11648 loop->op_nextop = o; 81256 o->op_flags |= flags; 81256 o->op_private |= (flags >> 8); 81256 return o; } OP * Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont) 51089 { dVAR; 51089 LOOP *loop; 51089 OP *wop; 51089 PADOFFSET padoff = 0; 51089 I32 iterflags = 0; 51089 I32 iterpflags = 0; 51089 if (sv) { 33324 if (sv->op_type == OP_RV2SV) { /* symbol table variable */ 274 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ 274 sv->op_type = OP_RV2GV; 274 sv->op_ppaddr = PL_ppaddr[OP_RV2GV]; } 33050 else if (sv->op_type == OP_PADSV) { /* private variable */ 33050 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */ 33050 padoff = sv->op_targ; 33050 sv->op_targ = 0; 33050 op_free(sv); 33050 sv = Nullop; } ###### else if (sv->op_type == OP_THREADSV) { /* per-thread variable */ ###### padoff = sv->op_targ; ###### sv->op_targ = 0; ###### iterflags |= OPf_SPECIAL; ###### op_free(sv); ###### sv = Nullop; } else ###### Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); } else { 17765 const I32 offset = pad_findmy("$_"); 17765 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { 17763 sv = newGVOP(OP_GV, 0, PL_defgv); } else { 2 padoff = offset; } } 51089 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { 32733 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART); 32733 iterflags |= OPf_STACKED; } 18356 else if (expr->op_type == OP_NULL && (expr->op_flags & OPf_KIDS) && ((BINOP*)expr)->op_first->op_type == OP_FLOP) { /* Basically turn for($x..$y) into the same as for($x,$y), but we * set the STACKED flag to indicate that these values are to be * treated as min/max values by 'pp_iterinit'. */ 4220 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; 4220 LOGOP* range = (LOGOP*) flip->op_first; 4220 OP* const left = range->op_first; 4220 OP* const right = left->op_sibling; 4220 LISTOP* listop; 4220 range->op_flags &= ~OPf_KIDS; 4220 range->op_first = Nullop; 4220 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); 4220 listop->op_first->op_next = range->op_next; 4220 left->op_next = range->op_other; 4220 right->op_next = (OP*)listop; 4220 listop->op_next = listop->op_first; 4220 op_free(expr); 4220 expr = (OP*)(listop); 4220 op_null(expr); 4220 iterflags |= OPf_STACKED; } else { 14136 expr = mod(force_list(expr), OP_GREPSTART); } 51089 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, append_elem(OP_LIST, expr, scalar(sv)))); 51089 assert(!loop->op_next); /* for my $x () sets OPpLVAL_INTRO; * for our $x () sets OPpOUR_INTRO */ 51089 loop->op_private = (U8)iterpflags; #ifdef PL_OP_SLAB_ALLOC { LOOP *tmp; NewOp(1234,tmp,1,LOOP); Copy(loop,tmp,1,LISTOP); FreeOp(loop); loop = tmp; } #else 51089 Renew(loop, 1, LOOP); #endif 51089 loop->op_targ = padoff; 51089 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0); 51089 PL_copline = forline; 51089 return newSTATEOP(0, label, wop); } OP* Perl_newLOOPEX(pTHX_ I32 type, OP *label) 26556 { 26556 OP *o; 26556 if (type != OP_GOTO || label->op_type == OP_CONST) { /* "last()" means "last" */ 8222 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) 18 o = newOP(type, OPf_SPECIAL); else { 8204 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST 8204 ? SvPVx_nolen_const(((SVOP*)label)->op_sv) : "")); } 8220 op_free(label); } else { /* Check whether it's going to be a goto &function */ 18334 if (label->op_type == OP_ENTERSUB && !(label->op_flags & OPf_STACKED)) 16955 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN)); 18334 o = newUNOP(type, OPf_STACKED, label); } 26554 PL_hints |= HINT_BLOCK_SCOPE; 26554 return o; } /* =for apidoc cv_undef Clear out all the active components of a CV. This can happen either by an explicit C, or by the reference count going to zero. In the former case, we keep the CvOUTSIDE pointer, so that any anonymous children can still follow the full lexical scope chain. =cut */ void Perl_cv_undef(pTHX_ CV *cv) 661158 { dVAR; #ifdef USE_ITHREADS if (CvFILE(cv) && !CvXSUB(cv)) { /* for XSUBs CvFILE point directly to static memory; __FILE__ */ Safefree(CvFILE(cv)); } CvFILE(cv) = 0; #endif 661158 if (!CvXSUB(cv) && CvROOT(cv)) { 274428 if (CvDEPTH(cv)) ###### Perl_croak(aTHX_ "Can't undef active subroutine"); 274428 ENTER; 274428 PAD_SAVE_SETNULLPAD(); 274428 op_free(CvROOT(cv)); 274428 CvROOT(cv) = Nullop; 274428 CvSTART(cv) = Nullop; 274428 LEAVE; } 661158 SvPOK_off((SV*)cv); /* forget prototype */ 661158 CvGV(cv) = Nullgv; 661158 pad_undef(cv); /* remove CvOUTSIDE unless this is an undef rather than a free */ 661158 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) { 380618 if (!CvWEAKOUTSIDE(cv)) 367140 SvREFCNT_dec(CvOUTSIDE(cv)); 380618 CvOUTSIDE(cv) = Nullcv; } 661158 if (CvCONST(cv)) { 31462 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); 31462 CvCONST_off(cv); } 661158 if (CvXSUB(cv)) { 232815 CvXSUB(cv) = 0; } /* delete all flags except WEAKOUTSIDE */ 661158 CvFLAGS(cv) &= CVf_WEAKOUTSIDE; } void Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p) 2707 { 2707 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { 13 SV* msg = sv_newmortal(); 13 SV* name = Nullsv; 13 if (gv) 13 gv_efullname3(name = sv_newmortal(), gv, Nullch); 13 sv_setpv(msg, "Prototype mismatch:"); 13 if (name) 13 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name); 13 if (SvPOK(cv)) 11 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv); else 2 Perl_sv_catpv(aTHX_ msg, ": none"); 13 sv_catpv(msg, " vs "); 13 if (p) 9 Perl_sv_catpvf(aTHX_ msg, "(%s)", p); else 4 sv_catpv(msg, "none"); 13 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg); } } static void const_sv_xsub(pTHX_ CV* cv); /* =head1 Optree Manipulation Functions =for apidoc cv_const_sv If C is a constant sub eligible for inlining. returns the constant value returned by the sub. Otherwise, returns NULL. Constant subs can be created with C or as described in L. =cut */ SV * Perl_cv_const_sv(pTHX_ CV *cv) 73884 { 73884 if (!cv || !CvCONST(cv)) 58206 return Nullsv; 15678 return (SV*)CvXSUBANY(cv).any_ptr; } /* op_const_sv: examine an optree to determine whether it's in-lineable. * Can be called in 3 ways: * * !cv * look for a single OP_CONST with attached value: return the value * * cv && CvCLONE(cv) && !CvCONST(cv) * * examine the clone prototype, and if contains only a single * OP_CONST referencing a pad const, or a single PADSV referencing * an outer lexical, return a non-zero value to indicate the CV is * a candidate for "constizing" at clone time * * cv && CvCONST(cv) * * We have just cloned an anon prototype that was marked as a const * candidiate. Try to grab the current value, and in the case of * PADSV, ignore it if it has multiple references. Return the value. */ SV * Perl_op_const_sv(pTHX_ const OP *o, CV *cv) 12317 { 12317 SV *sv = Nullsv; 12317 if (!o) ###### return Nullsv; 12317 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) 10243 o = cLISTOPo->op_first->op_sibling; 31205 for (; o; o = o->op_next) { 21590 OPCODE type = o->op_type; 21590 if (sv && o->op_next == o) 6948 return sv; 14642 if (o->op_next != o) { 6788 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) 4719 continue; 4719 if (type == OP_DBSTATE) ###### continue; } 12573 if (type == OP_LEAVESUB || type == OP_RETURN) 11987 break; 11987 if (sv) ###### return Nullsv; 11987 if (type == OP_CONST && cSVOPo->op_sv) 6948 sv = cSVOPo->op_sv; 5039 else if (cv && type == OP_CONST) { ###### sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); ###### if (!sv) ###### return Nullsv; } 5039 else if (cv && type == OP_PADSV) { 2269 if (CvCONST(cv)) { /* newly cloned anon */ 1842 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); /* the candidate should have 1 ref from this pad and 1 ref * from the parent */ 1842 if (!sv || SvREFCNT(sv) != 2) 1 return Nullsv; 1841 sv = newSVsv(sv); 1841 SvREADONLY_on(sv); 1841 return sv; } else { 427 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE) 427 sv = &PL_sv_undef; /* an arbitrary non-null value */ } } else { 2770 return Nullsv; } } 757 return sv; } void Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) ###### { ###### (void)floor; ###### if (o) ###### SAVEFREEOP(o); ###### if (proto) ###### SAVEFREEOP(proto); ###### if (attrs) ###### SAVEFREEOP(attrs); ###### if (block) ###### SAVEFREEOP(block); ###### Perl_croak(aTHX_ "\"my sub\" not yet implemented"); } CV * Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) 11135 { 11135 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block); } CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 301886 { dVAR; 301886 const char *aname; 301886 GV *gv; 301886 const char *ps; 301886 STRLEN ps_len; 301886 register CV *cv=0; 301886 SV *const_sv; 301886 I32 gv_fetch_flags; 301886 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch; 301886 if (proto) { 22540 assert(proto->op_type == OP_CONST); 22540 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len); } else 279346 ps = Nullch; 301886 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) { ###### SV *sv = sv_newmortal(); ###### Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]", PL_curstash ? "__ANON__" : "__ANON__::__ANON__", CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); ###### aname = SvPVX_const(sv); } else 301886 aname = Nullch; 301886 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; 301886 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV) : gv_fetchpv(aname ? aname : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), gv_fetch_flags, SVt_PVCV); 301886 if (o) 286925 SAVEFREEOP(o); 301886 if (proto) 22540 SAVEFREEOP(proto); 301886 if (attrs) 31 SAVEFREEOP(attrs); 301886 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at maximum a prototype before. */ 23628 if (SvTYPE(gv) > SVt_NULL) { 108 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1) && ckWARN_d(WARN_PROTOTYPE)) { ###### Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype"); } 108 cv_ckproto((CV*)gv, NULL, ps); } 23628 if (ps) 1777 sv_setpvn((SV*)gv, ps, ps_len); else 21851 sv_setiv((SV*)gv, -1); 23628 SvREFCNT_dec(PL_compcv); 23628 cv = PL_compcv = NULL; 23628 PL_sub_generation++; 23628 goto done; } 278258 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv); #ifdef GV_UNIQUE_CHECK if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) { Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name); } #endif 278258 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) 268425 const_sv = Nullsv; else 9833 const_sv = op_const_sv(block, Nullcv); 278258 if (cv) { 4180 const bool exists = CvROOT(cv) || CvXSUB(cv); #ifdef GV_UNIQUE_CHECK if (exists && GvUNIQUE(gv)) { Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name); } #endif /* if the subroutine doesn't exist and wasn't pre-declared * with a prototype, assume it will be AUTOLOADed, * skipping the prototype check */ 4180 if (exists || SvPOK(cv)) 1286 cv_ckproto(cv, gv, ps); /* already defined (or promised)? */ 4180 if (exists || GvASSUMECV(gv)) { 68 if (!block && !attrs) { 29 if (CvFLAGS(PL_compcv)) { /* might have had built-in attrs applied */ 1 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); } /* just a "sub foo;" when &foo is already defined */ 29 SAVEFREESV(PL_compcv); 29 goto done; } /* ahem, death to those who redefine active sort subs */ 39 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv)) 1 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); 38 if (block) { 36 if (ckWARN(WARN_REDEFINE) || (CvCONST(cv) && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv)))) { 18 const line_t oldline = CopLINE(PL_curcop); 18 if (PL_copline != NOLINE) 17 CopLINE_set(PL_curcop, PL_copline); 18 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), CvCONST(cv) ? "Constant subroutine %s redefined" : "Subroutine %s redefined", name); 18 CopLINE_set(PL_curcop, oldline); } 36 SvREFCNT_dec(cv); 36 cv = Nullcv; } } } 278228 if (const_sv) { 6948 (void)SvREFCNT_inc(const_sv); 6948 if (cv) { ###### assert(!CvROOT(cv) && !CvCONST(cv)); ###### sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ ###### CvXSUBANY(cv).any_ptr = const_sv; ###### CvXSUB(cv) = const_sv_xsub; ###### CvCONST_on(cv); } else { 6948 GvCV(gv) = Nullcv; 6948 cv = newCONSTSUB(NULL, name, const_sv); } 6948 op_free(block); 6948 SvREFCNT_dec(PL_compcv); 6948 PL_compcv = NULL; 6948 PL_sub_generation++; 6948 goto done; } 271280 if (attrs) { 31 HV *stash; 31 SV *rcv; /* Need to do a C * before we clobber PL_compcv. */ 31 if (cv && !block) { 2 rcv = (SV*)cv; /* Might have had built-in attributes applied -- propagate them. */ 2 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); 2 if (CvGV(cv) && GvSTASH(CvGV(cv))) 2 stash = GvSTASH(CvGV(cv)); ###### else if (CvSTASH(cv)) ###### stash = CvSTASH(cv); else ###### stash = PL_curstash; } else { /* possibly about to re-define existing subr -- ignore old cv */ 29 rcv = (SV*)PL_compcv; 29 if (name && GvSTASH(gv)) 29 stash = GvSTASH(gv); else ###### stash = PL_curstash; } 31 apply_attrs(stash, rcv, attrs, FALSE); } 271273 if (cv) { /* must reuse cv if autoloaded */ 4113 if (!block) { /* got here with just attrs -- work done, so bug out */ 8 SAVEFREESV(PL_compcv); 8 goto done; } /* transfer PL_compcv to cv */ 4105 cv_undef(cv); 4105 CvFLAGS(cv) = CvFLAGS(PL_compcv); 4105 if (!CvWEAKOUTSIDE(cv)) 4105 SvREFCNT_dec(CvOUTSIDE(cv)); 4105 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); 4105 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); 4105 CvOUTSIDE(PL_compcv) = 0; 4105 CvPADLIST(cv) = CvPADLIST(PL_compcv); 4105 CvPADLIST(PL_compcv) = 0; /* inner references to PL_compcv must be fixed up ... */ 4105 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); /* ... before we throw it away */ 4105 SvREFCNT_dec(PL_compcv); 4105 PL_compcv = cv; 4105 if (PERLDB_INTER)/* Advice debugger on the new sub. */ ###### ++PL_sub_generation; } else { 267160 cv = PL_compcv; 267160 if (name) { 252233 GvCV(gv) = cv; 252233 GvCVGEN(gv) = 0; 252233 PL_sub_generation++; } } 271265 CvGV(cv) = gv; 271265 CvFILE_set_from_cop(cv, PL_curcop); 271265 CvSTASH(cv) = PL_curstash; 271265 if (ps) 13811 sv_setpvn((SV*)cv, ps, ps_len); 271265 if (PL_error_count) { 27 op_free(block); 27 block = Nullop; 27 if (name) { 17 const char *s = strrchr(name, ':'); 17 s = s ? s+1 : name; 17 if (strEQ(s, "BEGIN")) { 2 const char not_safe[] = 2 "BEGIN not safe after errors--compilation aborted"; 2 if (PL_in_eval & EVAL_KEEPERR) ###### Perl_croak(aTHX_ not_safe); else { /* force display of errors found but not reported */ 2 sv_catpv(ERRSV, not_safe); 2 Perl_croak(aTHX_ "%"SVf, ERRSV); } } } } 271263 if (!block) 11223 goto done; 260040 if (CvLVALUE(cv)) { 50 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, mod(scalarseq(block), OP_LEAVESUBLV)); } else { /* This makes sub {}; work as expected. */ 259990 if (block->op_type == OP_STUB) { 3457 op_free(block); 3457 block = newSTATEOP(0, Nullch, 0); } 259990 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); } 260038 CvROOT(cv)->op_private |= OPpREFCOUNTED; 260038 OpREFCNT_set(CvROOT(cv), 1); 260038 CvSTART(cv) = LINKLIST(CvROOT(cv)); 260038 CvROOT(cv)->op_next = 0; 260038 CALL_PEEP(CvSTART(cv)); /* now that optimizer has done its work, adjust pad values */ 260038 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); 260038 if (CvCLONE(cv)) { 4506 assert(!CvCONST(cv)); 4506 if (ps && !*ps && op_const_sv(block, cv)) 427 CvCONST_on(cv); } 260038 if (name || aname) { 245121 const char *s; 245121 const char *tname = (name ? name : aname); 245121 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { 40 SV *sv = NEWSV(0,0); 40 SV *tmpstr = sv_newmortal(); 40 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV); 40 CV *pcv; 40 HV *hv; 40 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld", CopFILE(PL_curcop), (long)PL_subline, (long)CopLINE(PL_curcop)); 40 gv_efullname3(tmpstr, gv, Nullch); 40 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0); 40 hv = GvHVn(db_postponed); 40 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr)) && (pcv = GvCV(db_postponed))) { ###### dSP; ###### PUSHMARK(SP); ###### XPUSHs(tmpstr); ###### PUTBACK; ###### call_sv((SV*)pcv, G_DISCARD); } } 245121 if ((s = strrchr(tname,':'))) 3076 s++; else 242045 s = tname; 245121 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') 185739 goto done; 59382 if (strEQ(s, "BEGIN") && !PL_error_count) { 54305 const I32 oldscope = PL_scopestack_ix; 54305 ENTER; 54305 SAVECOPFILE(&PL_compiling); 54305 SAVECOPLINE(&PL_compiling); 54305 if (!PL_beginav) 2315 PL_beginav = newAV(); 54305 DEBUG_x( dump_sub(gv) ); 54305 av_push(PL_beginav, (SV*)cv); 54305 GvCV(gv) = 0; /* cv has been hijacked */ 54305 call_list(oldscope, PL_beginav); 54124 PL_curcop = &PL_compiling; 54124 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 54124 LEAVE; } 5077 else if (strEQ(s, "END") && !PL_error_count) { 1019 if (!PL_endav) 732 PL_endav = newAV(); 1019 DEBUG_x( dump_sub(gv) ); 1019 av_unshift(PL_endav, 1); 1019 av_store(PL_endav, 0, (SV*)cv); 1019 GvCV(gv) = 0; /* cv has been hijacked */ } 4058 else if (strEQ(s, "CHECK") && !PL_error_count) { 96 if (!PL_checkav) 86 PL_checkav = newAV(); 96 DEBUG_x( dump_sub(gv) ); 96 if (PL_main_start && ckWARN(WARN_VOID)) 2 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); 96 av_unshift(PL_checkav, 1); 96 av_store(PL_checkav, 0, (SV*)cv); 96 GvCV(gv) = 0; /* cv has been hijacked */ } 3962 else if (strEQ(s, "INIT") && !PL_error_count) { 14 if (!PL_initav) 11 PL_initav = newAV(); 14 DEBUG_x( dump_sub(gv) ); 14 if (PL_main_start && ckWARN(WARN_VOID)) 2 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); 14 av_push(PL_initav, (SV*)cv); 14 GvCV(gv) = 0; /* cv has been hijacked */ } } done: 301693 PL_copline = NOLINE; 301693 LEAVE_SCOPE(floor); 301693 return cv; } /* XXX unsafe for threads if eval_owner isn't held */ /* =for apidoc newCONSTSUB Creates a constant sub equivalent to Perl C which is eligible for inlining at compile-time. =cut */ CV * Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) 28284 { dVAR; 28284 CV* cv; 28284 ENTER; 28284 SAVECOPLINE(PL_curcop); 28284 CopLINE_set(PL_curcop, PL_copline); 28284 SAVEHINTS(); 28284 PL_hints &= ~HINT_BLOCK_SCOPE; 28284 if (stash) { 21336 SAVESPTR(PL_curstash); 21336 SAVECOPSTASH(PL_curcop); 21336 PL_curstash = stash; 21336 CopSTASH_set(PL_curcop,stash); } 28284 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop))); 28284 CvXSUBANY(cv).any_ptr = sv; 28284 CvCONST_on(cv); 28284 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ 28284 if (stash) CopSTASH_free(PL_curcop); 28284 LEAVE; 28284 return cv; } /* =for apidoc U||newXS Used by C to hook up XSUBs as Perl subs. =cut */ CV * Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) 229760 { 229760 GV *gv = gv_fetchpv(name ? name : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), 229760 GV_ADDMULTI, SVt_PVCV); 229760 register CV *cv; 229760 if (!subaddr) ###### Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename); 229760 if ((cv = (name ? GvCV(gv) : Nullcv))) { 777 if (GvCVGEN(gv)) { /* just a cached method */ 344 SvREFCNT_dec(cv); 344 cv = Nullcv; } 433 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { /* already defined (or promised) */ /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */ 219 if (ckWARN(WARN_REDEFINE)) { ###### GV * const gvcv = CvGV(cv); ###### if (gvcv) { ###### HV * const stash = GvSTASH(gvcv); ###### if (stash) { ###### const char *name = HvNAME_get(stash); ###### if ( strEQ(name,"autouse") ) { ###### const line_t oldline = CopLINE(PL_curcop); ###### if (PL_copline != NOLINE) ###### CopLINE_set(PL_curcop, PL_copline); ###### Perl_warner(aTHX_ packWARN(WARN_REDEFINE), CvCONST(cv) ? "Constant subroutine %s redefined" : "Subroutine %s redefined" ,name); ###### CopLINE_set(PL_curcop, oldline); } } } } 219 SvREFCNT_dec(cv); 219 cv = Nullcv; } } 229760 if (cv) /* must reuse cv if autoloaded */ 214 cv_undef(cv); else { 229546 cv = (CV*)NEWSV(1105,0); 229546 sv_upgrade((SV *)cv, SVt_PVCV); 229546 if (name) { 227671 GvCV(gv) = cv; 227671 GvCVGEN(gv) = 0; 227671 PL_sub_generation++; } } 229760 CvGV(cv) = gv; 229760 (void)gv_fetchfile(filename); 229760 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be an external constant string */ 229760 CvXSUB(cv) = subaddr; 229760 if (name) { 227885 const char *s = strrchr(name,':'); 227885 if (s) 201581 s++; else 26304 s = name; 227885 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') 220143 goto done; 7742 if (strEQ(s, "BEGIN")) { ###### if (!PL_beginav) ###### PL_beginav = newAV(); ###### av_push(PL_beginav, (SV*)cv); ###### GvCV(gv) = 0; /* cv has been hijacked */ } 7742 else if (strEQ(s, "END")) { 8 if (!PL_endav) 8 PL_endav = newAV(); 8 av_unshift(PL_endav, 1); 8 av_store(PL_endav, 0, (SV*)cv); 8 GvCV(gv) = 0; /* cv has been hijacked */ } 7734 else if (strEQ(s, "CHECK")) { ###### if (!PL_checkav) ###### PL_checkav = newAV(); ###### if (PL_main_start && ckWARN(WARN_VOID)) ###### Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); ###### av_unshift(PL_checkav, 1); ###### av_store(PL_checkav, 0, (SV*)cv); ###### GvCV(gv) = 0; /* cv has been hijacked */ } 7734 else if (strEQ(s, "INIT")) { ###### if (!PL_initav) ###### PL_initav = newAV(); ###### if (PL_main_start && ckWARN(WARN_VOID)) ###### Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); ###### av_push(PL_initav, (SV*)cv); ###### GvCV(gv) = 0; /* cv has been hijacked */ } } else 1875 CvANON_on(cv); done: 229760 return cv; } void Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) 88 { 88 register CV *cv; 88 GV *gv; 88 if (o) 85 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM); else 3 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM); #ifdef GV_UNIQUE_CHECK if (GvUNIQUE(gv)) { Perl_croak(aTHX_ "Bad symbol for form (GV is unique)"); } #endif 88 GvMULTI_on(gv); 88 if ((cv = GvFORM(gv))) { 4 if (ckWARN(WARN_REDEFINE)) { 1 const line_t oldline = CopLINE(PL_curcop); 1 if (PL_copline != NOLINE) 1 CopLINE_set(PL_curcop, PL_copline); 1 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), o ? "Format %"SVf" redefined" : "Format STDOUT redefined" ,cSVOPo->op_sv); 1 CopLINE_set(PL_curcop, oldline); } 4 SvREFCNT_dec(cv); } 88 cv = PL_compcv; 88 GvFORM(gv) = cv; 88 CvGV(cv) = gv; 88 CvFILE_set_from_cop(cv, PL_curcop); 88 pad_tidy(padtidy_FORMAT); 88 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); 88 CvROOT(cv)->op_private |= OPpREFCOUNTED; 88 OpREFCNT_set(CvROOT(cv), 1); 88 CvSTART(cv) = LINKLIST(CvROOT(cv)); 88 CvROOT(cv)->op_next = 0; 88 CALL_PEEP(CvSTART(cv)); 88 op_free(o); 88 PL_copline = NOLINE; 88 LEAVE_SCOPE(floor); } OP * Perl_newANONLIST(pTHX_ OP *o) 27439 { 27439 return newUNOP(OP_REFGEN, 0, mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN)); } OP * Perl_newANONHASH(pTHX_ OP *o) 18919 { 18919 return newUNOP(OP_REFGEN, 0, mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN)); } OP * Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block) ###### { ###### return newANONATTRSUB(floor, proto, Nullop, block); } OP * Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) 14961 { 14961 return newUNOP(OP_REFGEN, 0, newSVOP(OP_ANONCODE, 0, (SV*)newATTRSUB(floor, 0, proto, attrs, block))); } OP * Perl_oopsAV(pTHX_ OP *o) 107156 { dVAR; 107156 switch (o->op_type) { case OP_PADSV: 25426 o->op_type = OP_PADAV; 25426 o->op_ppaddr = PL_ppaddr[OP_PADAV]; 25426 return ref(o, OP_RV2AV); case OP_RV2SV: 81730 o->op_type = OP_RV2AV; 81730 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 81730 ref(o, OP_RV2AV); 81730 break; default: ###### if (ckWARN_d(WARN_INTERNAL)) ###### Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); 81730 break; } 81730 return o; } OP * Perl_oopsHV(pTHX_ OP *o) 185248 { dVAR; 185248 switch (o->op_type) { case OP_PADSV: case OP_PADAV: 61463 o->op_type = OP_PADHV; 61463 o->op_ppaddr = PL_ppaddr[OP_PADHV]; 61463 return ref(o, OP_RV2HV); case OP_RV2SV: case OP_RV2AV: 123785 o->op_type = OP_RV2HV; 123785 o->op_ppaddr = PL_ppaddr[OP_RV2HV]; 123785 ref(o, OP_RV2HV); 123785 break; default: ###### if (ckWARN_d(WARN_INTERNAL)) ###### Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); 123785 break; } 123785 return o; } OP * Perl_newAVREF(pTHX_ OP *o) 510633 { dVAR; 510633 if (o->op_type == OP_PADANY) { 167063 o->op_type = OP_PADAV; 167063 o->op_ppaddr = PL_ppaddr[OP_PADAV]; 167063 return o; } 343570 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV) && ckWARN(WARN_DEPRECATED)) { 4 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Using an array as a reference is deprecated"); } 343570 return newUNOP(OP_RV2AV, 0, scalar(o)); } OP * Perl_newGVREF(pTHX_ I32 type, OP *o) 73507 { 73507 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT) 13190 return newUNOP(OP_NULL, 0, o); 60317 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type); } OP * Perl_newHVREF(pTHX_ OP *o) 252778 { dVAR; 252778 if (o->op_type == OP_PADANY) { 29802 o->op_type = OP_PADHV; 29802 o->op_ppaddr = PL_ppaddr[OP_PADHV]; 29802 return o; } 222976 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV) && ckWARN(WARN_DEPRECATED)) { 4 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Using a hash as a reference is deprecated"); } 222976 return newUNOP(OP_RV2HV, 0, scalar(o)); } OP * Perl_oopsCV(pTHX_ OP *o) ###### { ###### Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__); /* STUB */ (void)o; NORETURN_FUNCTION_END; } OP * Perl_newCVREF(pTHX_ I32 flags, OP *o) 344769 { 344769 return newUNOP(OP_RV2CV, flags, scalar(o)); } OP * Perl_newSVREF(pTHX_ OP *o) 3426689 { dVAR; 3426689 if (o->op_type == OP_PADANY) { 2677482 o->op_type = OP_PADSV; 2677482 o->op_ppaddr = PL_ppaddr[OP_PADSV]; 2677482 return o; } 749207 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) { ###### o->op_flags |= OPpDONE_SVREF; ###### return o; } 749207 return newUNOP(OP_RV2SV, 0, scalar(o)); } /* Check routines. See the comments at the top of this file for details * on when these are called */ OP * Perl_ck_anoncode(pTHX_ OP *o) 14960 { 14960 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type); 14960 cSVOPo->op_sv = Nullsv; 14960 return o; } OP * Perl_ck_bitop(pTHX_ OP *o) 58696 { #define OP_IS_NUMCOMPARE(op) \ ((op) == OP_LT || (op) == OP_I_LT || \ (op) == OP_GT || (op) == OP_I_GT || \ (op) == OP_LE || (op) == OP_I_LE || \ (op) == OP_GE || (op) == OP_I_GE || \ (op) == OP_EQ || (op) == OP_I_EQ || \ (op) == OP_NE || (op) == OP_I_NE || \ (op) == OP_NCMP || (op) == OP_I_NCMP) 58696 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 58696 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */ && (o->op_type == OP_BIT_OR || o->op_type == OP_BIT_AND || o->op_type == OP_BIT_XOR)) { 17099 const OP * const left = cBINOPo->op_first; 17099 const OP * const right = left->op_sibling; 17099 if ((OP_IS_NUMCOMPARE(left->op_type) && (left->op_flags & OPf_PARENS) == 0) || (OP_IS_NUMCOMPARE(right->op_type) && (right->op_flags & OPf_PARENS) == 0)) 28 if (ckWARN(WARN_PRECEDENCE)) 14 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE), "Possible precedence problem on bitwise %c operator", o->op_type == OP_BIT_OR ? '|' : o->op_type == OP_BIT_AND ? '&' : '^' ); } 58696 return o; } OP * Perl_ck_concat(pTHX_ OP *o) 519765 { 519765 const OP *kid = cUNOPo->op_first; 519765 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) && !(kUNOP->op_first->op_flags & OPf_MOD)) 250975 o->op_flags |= OPf_STACKED; 519765 return o; } OP * Perl_ck_spair(pTHX_ OP *o) 151224 { dVAR; 151224 if (o->op_flags & OPf_KIDS) { 150086 OP* newop; 150086 OP* kid; 150086 const OPCODE type = o->op_type; 150086 o = modkids(ck_fun(o), type); 150086 kid = cUNOPo->op_first; 150086 newop = kUNOP->op_first->op_sibling; 150086 if (newop && (newop->op_sibling || !(PL_opargs[newop->op_type] & OA_RETSCALAR) || newop->op_type == OP_PADAV || newop->op_type == OP_PADHV || newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) { 80444 return o; } 69642 op_free(kUNOP->op_first); 69642 kUNOP->op_first = newop; } 70780 o->op_ppaddr = PL_ppaddr[++o->op_type]; 70780 return ck_fun(o); } OP * Perl_ck_delete(pTHX_ OP *o) 9173 { 9173 o = ck_fun(o); 9173 o->op_private = 0; 9173 if (o->op_flags & OPf_KIDS) { 9173 OP *kid = cUNOPo->op_first; 9173 switch (kid->op_type) { case OP_ASLICE: 2 o->op_flags |= OPf_SPECIAL; /* FALL THROUGH */ case OP_HSLICE: 121 o->op_private |= OPpSLICE; 121 break; case OP_AELEM: 28 o->op_flags |= OPf_SPECIAL; /* FALL THROUGH */ case OP_HELEM: 28 break; default: ###### Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", OP_DESC(o)); } 9173 op_null(kid); } 9173 return o; } OP * Perl_ck_die(pTHX_ OP *o) 20749 { #ifdef VMS if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; #endif 20749 return ck_fun(o); } OP * Perl_ck_eof(pTHX_ OP *o) 464 { 464 const I32 type = o->op_type; 464 if (o->op_flags & OPf_KIDS) { 441 if (cLISTOPo->op_first->op_type == OP_STUB) { ###### op_free(o); ###### o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); } 441 return ck_fun(o); } 23 return o; } OP * Perl_ck_eval(pTHX_ OP *o) 16154 { dVAR; 16154 PL_hints |= HINT_BLOCK_SCOPE; 16154 if (o->op_flags & OPf_KIDS) { 16133 SVOP *kid = (SVOP*)cUNOPo->op_first; 16133 if (!kid) { ###### o->op_flags &= ~OPf_KIDS; ###### op_null(o); } 16133 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { 8076 LOGOP *enter; 8076 cUNOPo->op_first = 0; 8076 op_free(o); 8076 NewOp(1101, enter, 1, LOGOP); 8076 enter->op_type = OP_ENTERTRY; 8076 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY]; 8076 enter->op_private = 0; /* establish postfix order */ 8076 enter->op_next = (OP*)enter; 8076 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); 8076 o->op_type = OP_LEAVETRY; 8076 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; 8076 enter->op_other = o; 8076 return o; } else { 8057 scalar((OP*)kid); 8057 PL_cv_has_eval = 1; } } else { 21 op_free(o); 21 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP()); } 8078 o->op_targ = (PADOFFSET)PL_hints; 8078 return o; } OP * Perl_ck_exit(pTHX_ OP *o) 2756 { #ifdef VMS HV *table = GvHV(PL_hintgv); if (table) { SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE); if (svp && *svp && SvTRUE(*svp)) o->op_private |= OPpEXIT_VMSISH; } if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; #endif 2756 return ck_fun(o); } OP * Perl_ck_exec(pTHX_ OP *o) 635 { 635 if (o->op_flags & OPf_STACKED) { 10 OP *kid; 10 o = ck_fun(o); 10 kid = cUNOPo->op_first->op_sibling; 10 if (kid->op_type == OP_RV2GV) 10 op_null(kid); } else 625 o = listkids(o); 635 return o; } OP * Perl_ck_exists(pTHX_ OP *o) 17142 { 17142 o = ck_fun(o); 17142 if (o->op_flags & OPf_KIDS) { 17142 OP *kid = cUNOPo->op_first; 17142 if (kid->op_type == OP_ENTERSUB) { 334 (void) ref(kid, o->op_type); 334 if (kid->op_type != OP_RV2CV && !PL_error_count) 1 Perl_croak(aTHX_ "%s argument is not a subroutine name", OP_DESC(o)); 333 o->op_private |= OPpEXISTS_SUB; } 16808 else if (kid->op_type == OP_AELEM) 38 o->op_flags |= OPf_SPECIAL; 16770 else if (kid->op_type != OP_HELEM) ###### Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element", OP_DESC(o)); 17141 op_null(kid); } 17141 return o; } OP * Perl_ck_rvconst(pTHX_ register OP *o) 1804120 { dVAR; 1804120 SVOP *kid = (SVOP*)cUNOPo->op_first; 1804120 o->op_private |= (PL_hints & HINT_STRICT_REFS); 1804120 if (kid->op_type == OP_CONST) { 1276013 int iscv; 1276013 GV *gv; 1276013 SV * const kidsv = kid->op_sv; /* Is it a constant from cv_const_sv()? */ 1276013 if (SvROK(kidsv) && SvREADONLY(kidsv)) { 42 SV *rsv = SvRV(kidsv); 42 const int svtype = SvTYPE(rsv); 42 const char *badtype = Nullch; 42 switch (o->op_type) { case OP_RV2SV: ###### if (svtype > SVt_PVMG) ###### badtype = "a SCALAR"; ###### break; case OP_RV2AV: 5 if (svtype != SVt_PVAV) ###### badtype = "an ARRAY"; ###### break; case OP_RV2HV: 5 if (svtype != SVt_PVHV) 1 badtype = "a HASH"; 1 break; case OP_RV2CV: 32 if (svtype != SVt_PVCV) ###### badtype = "a CODE"; break; } 42 if (badtype) 1 Perl_croak(aTHX_ "Constant is not %s reference", badtype); 41 return o; } 1275971 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { 115903 const char *badthing = Nullch; 115903 switch (o->op_type) { case OP_RV2SV: ###### badthing = "a SCALAR"; ###### break; case OP_RV2AV: 1 badthing = "an ARRAY"; 1 break; case OP_RV2HV: 1 badthing = "a HASH"; break; } 115903 if (badthing) 2 Perl_croak(aTHX_ "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use", kidsv, badthing); } /* * This is a little tricky. We only want to add the symbol if we * didn't add it in the lexer. Otherwise we get duplicate strict * warnings. But if we didn't add it in the lexer, we must at * least pretend like we wanted to add it even if it existed before, * or we get possible typo warnings. OPpCONST_ENTERED says * whether the lexer already added THIS instance of this symbol. */ 1275969 iscv = (o->op_type == OP_RV2CV) * 2; 1275969 do { 1275969 gv = gv_fetchsv(kidsv, iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV : o->op_type == OP_RV2SV ? SVt_PV : o->op_type == OP_RV2AV ? SVt_PVAV : o->op_type == OP_RV2HV ? SVt_PVHV : SVt_PVGV); 1275969 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++); 1275969 if (gv) { 1275936 kid->op_type = OP_GV; 1275936 SvREFCNT_dec(kid->op_sv); #ifdef USE_ITHREADS /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); GvIN_PAD_on(gv); PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv)); #else 1275936 kid->op_sv = SvREFCNT_inc(gv); #endif 1275936 kid->op_private = 0; 1275936 kid->op_ppaddr = PL_ppaddr[OP_GV]; } } 1804076 return o; } OP * Perl_ck_ftst(pTHX_ OP *o) 26852 { dVAR; 26852 const I32 type = o->op_type; 26852 if (o->op_flags & OPf_REF) { /* nothing */ } 23628 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { 22805 SVOP *kid = (SVOP*)cUNOPo->op_first; 22805 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 3223 OP *newop = newGVOP(type, OPf_REF, 3223 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO)); 3223 op_free(o); 3223 o = newop; 3223 return o; } else { 19582 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o)) 2 o->op_private |= OPpFT_ACCESS; } 19582 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst) && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT) 13 o->op_private |= OPpFT_STACKED; } else { 823 op_free(o); 823 if (type == OP_FTTTY) 1 o = newGVOP(type, OPf_REF, PL_stdingv); else 822 o = newUNOP(type, 0, newDEFSVOP()); } 23629 return o; } OP * Perl_ck_fun(pTHX_ OP *o) 1466658 { 1466658 const int type = o->op_type; 1466658 register I32 oa = PL_opargs[type] >> OASHIFT; 1466658 if (o->op_flags & OPf_STACKED) { 10 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) 10 oa &= ~OA_OPTIONAL; else ###### return no_fh_allowed(o); } 1466658 if (o->op_flags & OPf_KIDS) { 1426591 OP **tokid = &cLISTOPo->op_first; 1426591 register OP *kid = cLISTOPo->op_first; 1426591 OP *sibl; 1426591 I32 numargs = 0; 1426591 if (kid->op_type == OP_PUSHMARK || (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) { 690579 tokid = &kid->op_sibling; 690579 kid = kid->op_sibling; } 1426591 if (!kid && PL_opargs[type] & OA_DEFGV) 10 *tokid = kid = newDEFSVOP(); 3061323 while (oa && kid) { 1634735 numargs++; 1634735 sibl = kid->op_sibling; 1634735 switch (oa & 7) { case OA_SCALAR: /* list seen where single (scalar) arg expected? */ 1109704 if (numargs == 1 && !(oa >> 4) && kid->op_type == OP_LIST && type != OP_SCALAR) { 3 return too_many_arguments(o,PL_op_desc[type]); } 1109701 scalar(kid); 1109701 break; case OA_LIST: 333092 if (oa < 16) { 333092 kid = 0; 333092 continue; } else ###### list(kid); ###### break; case OA_AVREF: 127080 if ((type == OP_PUSH || type == OP_UNSHIFT) && !kid->op_sibling && ckWARN(WARN_SYNTAX)) 2 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Useless use of %s with no values", PL_op_desc[type]); 127080 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 13 OP *newop = newAVREF(newGVOP(OP_GV, 0, 13 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) )); 13 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) 1 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]); 13 op_free(kid); 13 kid = newop; 13 kid->op_sibling = sibl; 13 *tokid = kid; } 127067 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) ###### bad_type(numargs, "array", PL_op_desc[type], kid); 127080 mod(kid, type); 127080 break; case OA_HVREF: 15216 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 6 OP *newop = newHVREF(newGVOP(OP_GV, 0, 6 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) )); 6 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) 1 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]); 6 op_free(kid); 6 kid = newop; 6 kid->op_sibling = sibl; 6 *tokid = kid; } 15210 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) ###### bad_type(numargs, "hash", PL_op_desc[type], kid); 15216 mod(kid, type); 15216 break; case OA_CVREF: { 21858 OP *newop = newUNOP(OP_NULL, 0, kid); 21858 kid->op_sibling = 0; 21858 linklist(kid); 21858 newop->op_next = newop; 21858 kid = newop; 21858 kid->op_sibling = sibl; 21858 *tokid = kid; } 21858 break; case OA_FILEREF: 23938 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) { 23881 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 13000 OP *newop = newGVOP(OP_GV, 0, 13000 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) ); 13000 if (!(o->op_private & 1) && /* if not unop */ kid == cLISTOPo->op_last) 572 cLISTOPo->op_last = newop; 13000 op_free(kid); 13000 kid = newop; } 10881 else if (kid->op_type == OP_READLINE) { /* neophyte patrol: open(), close() etc. */ ###### bad_type(numargs, "HANDLE", OP_DESC(o), kid); } else { 10881 I32 flags = OPf_SPECIAL; 10881 I32 priv = 0; 10881 PADOFFSET targ = 0; /* is this op a FH constructor? */ 10881 if (is_handle_constructor(o,numargs)) { 3953 const char *name = Nullch; 3953 STRLEN len = 0; 3953 flags = 0; /* Set a flag to tell rv2gv to vivify * need to "prove" flag does not mean something * else already - NI-S 1999/05/07 */ 3953 priv = OPpDEREF; 3953 if (kid->op_type == OP_PADSV) { 3215 name = PAD_COMPNAME_PV(kid->op_targ); /* SvCUR of a pad namesv can't be trusted * (see PL_generation), so calc its length * manually */ 3215 if (name) 3215 len = strlen(name); } 738 else if (kid->op_type == OP_RV2SV && kUNOP->op_first->op_type == OP_GV) { 43 GV *gv = cGVOPx_gv(kUNOP->op_first); 43 name = GvNAME(gv); 43 len = GvNAMELEN(gv); } 695 else if (kid->op_type == OP_AELEM || kid->op_type == OP_HELEM) { 205 OP *op; 205 name = 0; 205 if ((op = ((BINOP*)kid)->op_first)) { 205 SV *tmpstr = Nullsv; 205 const char *a = kid->op_type == OP_AELEM ? 205 "[]" : "{}"; 205 if (((op->op_type == OP_RV2AV) || (op->op_type == OP_RV2HV)) && (op = ((UNOP*)op)->op_first) && (op->op_type == OP_GV)) { /* packagevar $a[] or $h{} */ 125 GV *gv = cGVOPx_gv(op); 125 if (gv) 125 tmpstr = Perl_newSVpvf(aTHX_ "%s%c...%c", GvNAME(gv), a[0], a[1]); } 80 else if (op->op_type == OP_PADAV || op->op_type == OP_PADHV) { /* lexicalvar $a[] or $h{} */ 10 const char *padname = 10 PAD_COMPNAME_PV(op->op_targ); 10 if (padname) 10 tmpstr = Perl_newSVpvf(aTHX_ "%s%c...%c", padname + 1, a[0], a[1]); } 205 if (tmpstr) { 135 name = SvPV_const(tmpstr, len); 135 sv_2mortal(tmpstr); } } 205 if (!name) { 70 name = "__ANONIO__"; 70 len = 10; } 205 mod(kid, type); } 3953 if (name) { 3463 SV *namesv; 3463 targ = pad_alloc(OP_RV2GV, SVs_PADTMP); 3463 namesv = PAD_SVl(targ); 3463 SvUPGRADE(namesv, SVt_PV); 3463 if (*name != '$') 248 sv_setpvn(namesv, "$", 1); 3463 sv_catpvn(namesv, name, len); } } 10881 kid->op_sibling = 0; 10881 kid = newUNOP(OP_RV2GV, flags, scalar(kid)); 10881 kid->op_targ = targ; 10881 kid->op_private |= priv; } 23881 kid->op_sibling = sibl; 23881 *tokid = kid; } 23938 scalar(kid); 23938 break; case OA_SCALARREF: 3847 mod(scalar(kid), type); break; } 1301640 oa >>= 4; 1301640 tokid = &kid->op_sibling; 1301640 kid = kid->op_sibling; } 1426588 o->op_private |= numargs; 1426588 if (kid) ###### return too_many_arguments(o,OP_DESC(o)); 1426588 listkids(o); } 40067 else if (PL_opargs[type] & OA_DEFGV) { 3233 op_free(o); 3233 return newUNOP(type, 0, newDEFSVOP()); } 1463422 if (oa) { 463186 while (oa & OA_OPTIONAL) 57689 oa >>= 4; 405497 if (oa && oa != OA_LIST) 2 return too_few_arguments(o,OP_DESC(o)); } 1463420 return o; } OP * Perl_ck_glob(pTHX_ OP *o) 345 { dVAR; 345 GV *gv; 345 o = ck_fun(o); 345 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) 3 append_elem(OP_GLOB, o, newDEFSVOP()); 345 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvCVu(gv) && GvIMPORTED_CV(gv))) { 328 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); } #if !defined(PERL_EXTERNAL_GLOB) /* XXX this can be tightened up and made more failsafe. */ 345 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { 174 GV *glob_gv; 174 ENTER; 174 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv); 174 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); 174 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV); 174 GvCV(gv) = GvCV(glob_gv); 174 (void)SvREFCNT_inc((SV*)GvCV(gv)); 174 GvIMPORTED_CV_on(gv); 174 LEAVE; } #endif /* PERL_EXTERNAL_GLOB */ 345 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { 345 append_elem(OP_GLOB, o, newSVOP(OP_CONST, 0, newSViv(PL_glob_index++))); 345 o->op_type = OP_LIST; 345 o->op_ppaddr = PL_ppaddr[OP_LIST]; 345 cLISTOPo->op_first->op_type = OP_PUSHMARK; 345 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK]; 345 cLISTOPo->op_first->op_targ = 0; 345 o = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, o, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv))))); 345 o = newUNOP(OP_NULL, 0, ck_subr(o)); 345 o->op_targ = OP_GLOB; /* hint at what it used to be */ 345 return o; } ###### gv = newGVgen("main"); ###### gv_IOadd(gv); ###### append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); ###### scalarkids(o); ###### return o; } OP * Perl_ck_grep(pTHX_ OP *o) 21858 { dVAR; 21858 LOGOP *gwop; 21858 OP *kid; 21858 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; 21858 I32 offset; 21858 o->op_ppaddr = PL_ppaddr[OP_GREPSTART]; 21858 NewOp(1101, gwop, 1, LOGOP); 21858 if (o->op_flags & OPf_STACKED) { 11339 OP* k; 11339 o = ck_sort(o); 11339 kid = cLISTOPo->op_first->op_sibling; 11339 if (!cUNOPx(kid)->op_next) ###### Perl_croak(aTHX_ "panic: ck_grep"); 22678 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) { 11339 kid = k; } 11339 kid->op_next = (OP*)gwop; 11339 o->op_flags &= ~OPf_STACKED; } 21858 kid = cLISTOPo->op_first->op_sibling; 21858 if (type == OP_MAPWHILE) 13131 list(kid); else 8727 scalar(kid); 21858 o = ck_fun(o); 21858 if (PL_error_count) ###### return o; 21858 kid = cLISTOPo->op_first->op_sibling; 21858 if (kid->op_type != OP_NULL) ###### Perl_croak(aTHX_ "panic: ck_grep"); 21858 kid = kUNOP->op_first; 21858 gwop->op_type = type; 21858 gwop->op_ppaddr = PL_ppaddr[type]; 21858 gwop->op_first = listkids(o); 21858 gwop->op_flags |= OPf_KIDS; 21858 gwop->op_other = LINKLIST(kid); 21858 kid->op_next = (OP*)gwop; 21858 offset = pad_findmy("$_"); 21858 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { 21852 o->op_private = gwop->op_private = 0; 21852 gwop->op_targ = pad_alloc(type, SVs_PADTMP); } else { 6 o->op_private = gwop->op_private = OPpGREP_LEX; 6 gwop->op_targ = o->op_targ = offset; } 21858 kid = cLISTOPo->op_first->op_sibling; 21858 if (!kid || !kid->op_sibling) ###### return too_few_arguments(o,OP_DESC(o)); 89556 for (kid = kid->op_sibling; kid; kid = kid->op_sibling) 67698 mod(kid, OP_GREPSTART); 21858 return (OP*)gwop; } OP * Perl_ck_index(pTHX_ OP *o) 3899 { 3899 if (o->op_flags & OPf_KIDS) { 3899 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 3899 if (kid) 3899 kid = kid->op_sibling; /* get past "big" */ 3899 if (kid && kid->op_type == OP_CONST) 2815 fbm_compile(((SVOP*)kid)->op_sv, 0); } 3899 return ck_fun(o); } OP * Perl_ck_lengthconst(pTHX_ OP *o) 17497 { /* XXX length optimization goes here */ 17497 return ck_fun(o); } OP * Perl_ck_lfun(pTHX_ OP *o) 75709 { 75709 const OPCODE type = o->op_type; 75709 return modkids(ck_fun(o), type); } OP * Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ 91532 { 91532 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) { 40181 switch (cUNOPo->op_first->op_type) { case OP_RV2AV: /* This is needed for if (defined %stash::) to work. Do not break Tk. */ 2 break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ 2 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "defined(@array) is deprecated"); 2 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "\t(Maybe you should just omit the defined()?)\n"); 2 break; case OP_RV2HV: /* This is needed for if (defined %stash::) to work. Do not break Tk. */ 1 break; /* Globals via GV can be undef */ case OP_PADHV: 1 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "defined(%%hash) is deprecated"); 1 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "\t(Maybe you should just omit the defined()?)\n"); break; default: /* no warning */ 91532 break; } } 91532 return ck_rfun(o); } OP * Perl_ck_rfun(pTHX_ OP *o) 91533 { 91533 const OPCODE type = o->op_type; 91533 return refkids(ck_fun(o), type); } OP * Perl_ck_listiob(pTHX_ OP *o) 43543 { 43543 register OP *kid; 43543 kid = cLISTOPo->op_first; 43543 if (!kid) { ###### o = force_list(o); ###### kid = cLISTOPo->op_first; } 43543 if (kid->op_type == OP_PUSHMARK) 43543 kid = kid->op_sibling; 43543 if (kid && o->op_flags & OPf_STACKED) 19230 kid = kid->op_sibling; 24313 else if (kid && !kid->op_sibling) { /* print HANDLE; */ 20316 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) { 10 o->op_flags |= OPf_STACKED; /* make it a filehandle */ 10 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); 10 cLISTOPo->op_first->op_sibling = kid; 10 cLISTOPo->op_last = kid; 10 kid = kid->op_sibling; } } 43543 if (!kid) 182 append_elem(o->op_type, o, newDEFSVOP()); 43543 return listkids(o); } OP * Perl_ck_sassign(pTHX_ OP *o) 688633 { 688633 OP *kid = cLISTOPo->op_first; /* has a disposable target? */ 688633 if ((PL_opargs[kid->op_type] & OA_TARGLEX) && !(kid->op_flags & OPf_STACKED) /* Cannot steal the second time! */ && !(kid->op_private & OPpTARGET_MY)) { 56756 OP *kkid = kid->op_sibling; /* Can just relocate the target. */ 56756 if (kkid && kkid->op_type == OP_PADSV && !(kkid->op_private & OPpLVAL_INTRO)) { 24277 kid->op_targ = kkid->op_targ; 24277 kkid->op_targ = 0; /* Now we do not need PADSV and SASSIGN. */ 24277 kid->op_sibling = o->op_sibling; /* NULL */ 24277 cLISTOPo->op_first = NULL; 24277 op_free(o); 24277 op_free(kkid); 24277 kid->op_private |= OPpTARGET_MY; /* Used for context settings */ 24277 return kid; } } /* optimise C to C */ 664356 if (kid->op_type == OP_UNDEF) { 5468 OP *kkid = kid->op_sibling; 5468 if (kkid && kkid->op_type == OP_PADSV && (kkid->op_private & OPpLVAL_INTRO)) { 551 cLISTOPo->op_first = NULL; 551 kid->op_sibling = NULL; 551 op_free(o); 551 op_free(kid); 551 return kkid; } } 663805 return o; } OP * Perl_ck_match(pTHX_ OP *o) 165379 { 165379 if (o->op_type != OP_QR) { 156374 const I32 offset = pad_findmy("$_"); 156374 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) { 33 o->op_targ = offset; 33 o->op_private |= OPpTARGET_MY; } } 165379 if (o->op_type == OP_MATCH || o->op_type == OP_QR) 107133 o->op_private |= OPpRUNTIME; 165379 return o; } OP * Perl_ck_method(pTHX_ OP *o) 215105 { 215105 OP *kid = cUNOPo->op_first; 215105 if (kid->op_type == OP_CONST) { 213838 SV* sv = kSVOP->op_sv; 213838 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) { 211935 OP *cmop; 211935 if (!SvREADONLY(sv) || !SvFAKE(sv)) { 211935 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0); } else { ###### kSVOP->op_sv = Nullsv; } 211935 cmop = newSVOP(OP_METHOD_NAMED, 0, sv); 211934 op_free(o); 211934 return cmop; } } 3170 return o; } OP * Perl_ck_null(pTHX_ OP *o) 14192189 { 14192189 return o; } OP * Perl_ck_open(pTHX_ OP *o) 8074 { 8074 HV *table = GvHV(PL_hintgv); 8074 if (table) { 314 SV **svp; 314 I32 mode; 314 svp = hv_fetch(table, "open_IN", 7, FALSE); 314 if (svp && *svp) { 4 mode = mode_from_discipline(*svp); 314 if (mode & O_BINARY) 314 o->op_private |= OPpOPEN_IN_RAW; 314 else if (mode & O_TEXT) 314 o->op_private |= OPpOPEN_IN_CRLF; } 314 svp = hv_fetch(table, "open_OUT", 8, FALSE); 314 if (svp && *svp) { ###### mode = mode_from_discipline(*svp); 8074 if (mode & O_BINARY) 8074 o->op_private |= OPpOPEN_OUT_RAW; 8074 else if (mode & O_TEXT) 8074 o->op_private |= OPpOPEN_OUT_CRLF; } } 8074 if (o->op_type == OP_BACKTICK) 1401 return o; { /* In case of three-arg dup open remove strictness * from the last arg if it is a bareword. */ 6673 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */ 6673 OP *last = cLISTOPx(o)->op_last; /* The bareword. */ 6673 OP *oa; 6673 const char *mode; 6673 if ((last->op_type == OP_CONST) && /* The bareword. */ (last->op_private & OPpCONST_BARE) && (last->op_private & OPpCONST_STRICT) && (oa = first->op_sibling) && /* The fh. */ (oa = oa->op_sibling) && /* The mode. */ SvPOK(((SVOP*)oa)->op_sv) && (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && mode[0] == '>' && mode[1] == '&' && /* A dup open. */ (last == oa->op_sibling)) /* The bareword. */ 1 last->op_private &= ~OPpCONST_STRICT; } 6673 return ck_fun(o); } OP * Perl_ck_repeat(pTHX_ OP *o) 7128 { 7128 if (cBINOPo->op_first->op_flags & OPf_PARENS) { 3789 o->op_private |= OPpREPEAT_DOLIST; 3789 cBINOPo->op_first = force_list(cBINOPo->op_first); } else 3339 scalar(o); 7128 return o; } OP * Perl_ck_require(pTHX_ OP *o) 109375 { 109375 GV* gv; 109375 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ 109375 SVOP *kid = (SVOP*)cUNOPo->op_first; 109375 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 98252 SV *sv = kid->op_sv; 98252 U32 was_readonly = SvREADONLY(sv); 98252 char *s; 98252 if (was_readonly) { 98252 if (SvFAKE(sv)) { ###### sv_force_normal_flags(sv, 0); ###### assert(!SvREADONLY(sv)); ###### was_readonly = 0; } else { 98252 SvREADONLY_off(sv); } } 770674 for (s = SvPVX(sv); *s; s++) { 672422 if (*s == ':' && s[1] == ':') { 21410 *s = '/'; 21410 Move(s+2, s+1, strlen(s+2)+1, char); 21410 SvCUR_set(sv, SvCUR(sv) - 1); } } 98252 sv_catpvn(sv, ".pm", 3); 98252 SvFLAGS(sv) |= was_readonly; } } /* handle override, if any */ 109375 gv = gv_fetchpv("require", FALSE, SVt_PVCV); 109375 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) 109375 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV); 109375 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { 8 OP *kid = cUNOPo->op_first; 8 cUNOPo->op_first = 0; 8 op_free(o); 8 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, kid, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv)))))); } 109367 return ck_fun(o); } OP * Perl_ck_return(pTHX_ OP *o) 149448 { 149448 if (CvLVALUE(PL_compcv)) { 6 OP *kid; 12 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 6 mod(kid, OP_LEAVESUBLV); } 149448 return o; } #if 0 OP * Perl_ck_retarget(pTHX_ OP *o) { Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__); /* STUB */ return o; } #endif OP * Perl_ck_select(pTHX_ OP *o) 1842 { dVAR; 1842 OP* kid; 1842 if (o->op_flags & OPf_KIDS) { 1842 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 1842 if (kid && kid->op_sibling) { 85 o->op_type = OP_SSELECT; 85 o->op_ppaddr = PL_ppaddr[OP_SSELECT]; 85 o = ck_fun(o); 85 return fold_constants(o); } } 1757 o = ck_fun(o); 1757 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 1757 if (kid && kid->op_type == OP_RV2GV) 1547 kid->op_private &= ~HINT_STRICT_REFS; 1757 return o; } OP * Perl_ck_shift(pTHX_ OP *o) 152791 { 152791 const I32 type = o->op_type; 152791 if (!(o->op_flags & OPf_KIDS)) { 71948 OP *argop; 71948 op_free(o); 71948 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv))); 71948 return newUNOP(type, 0, scalar(argop)); } 80843 return scalar(modkids(ck_fun(o), type)); } OP * Perl_ck_sort(pTHX_ OP *o) 16757 { 16757 OP *firstkid; 16757 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) 1850 simplify_sort(o); 16757 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 16757 if (o->op_flags & OPf_STACKED) { /* may have been cleared */ 12857 OP *k = NULL; 12857 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ 12857 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { 12772 linklist(kid); 12772 if (kid->op_type == OP_SCOPE) { 7530 k = kid->op_next; 7530 kid->op_next = 0; } 5242 else if (kid->op_type == OP_LEAVE) { 5242 if (o->op_type == OP_SORT) { 164 op_null(kid); /* wipe out leave */ 164 kid->op_next = kid; 4225 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { 4061 if (k->op_next == kid) 164 k->op_next = 0; /* don't descend into loops */ 3897 else if (k->op_type == OP_ENTERLOOP || k->op_type == OP_ENTERITER) { 108 k = cLOOPx(k)->op_lastop; } } } else 5078 kid->op_next = 0; /* just disconnect the leave */ 5242 k = kLISTOP->op_first; } 12772 CALL_PEEP(k); 12772 kid = firstkid; 12772 if (o->op_type == OP_SORT) { /* provide scalar context for comparison function/block */ 1433 kid = scalar(kid); 1433 kid->op_next = kid; } else 11339 kid->op_next = k; 12772 o->op_flags |= OPf_SPECIAL; } 85 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) 41 op_null(firstkid); 12857 firstkid = firstkid->op_sibling; } /* provide list context for arguments */ 16757 if (o->op_type == OP_SORT) 5418 list(firstkid); 16757 return o; } STATIC void S_simplify_sort(pTHX_ OP *o) 1850 { 1850 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 1850 OP *k; 1850 int descending; 1850 GV *gv; 1850 const char *gvname; 1850 if (!(o->op_flags & OPf_STACKED)) ###### return; 1850 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV)); 1850 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV)); 1850 kid = kUNOP->op_first; /* get past null */ 1850 if (kid->op_type != OP_SCOPE) 249 return; 1601 kid = kLISTOP->op_last; /* get past scope */ 1601 switch(kid->op_type) { case OP_NCMP: case OP_I_NCMP: case OP_SCMP: 1062 break; default: 1062 return; } 1062 k = kid; /* remember this node*/ 1062 if (kBINOP->op_first->op_type != OP_RV2SV) 712 return; 350 kid = kBINOP->op_first; /* get past cmp */ 350 if (kUNOP->op_first->op_type != OP_GV) 17 return; 333 kid = kUNOP->op_first; /* get past rv2sv */ 333 gv = kGVOP_gv; 333 if (GvSTASH(gv) != PL_curstash) 1 return; 332 gvname = GvNAME(gv); 332 if (*gvname == 'a' && gvname[1] == '\0') 301 descending = 0; 31 else if (*gvname == 'b' && gvname[1] == '\0') 31 descending = 1; else 332 return; 332 kid = k; /* back to cmp */ 332 if (kBINOP->op_last->op_type != OP_RV2SV) ###### return; 332 kid = kBINOP->op_last; /* down to 2nd arg */ 332 if (kUNOP->op_first->op_type != OP_GV) ###### return; 332 kid = kUNOP->op_first; /* get past rv2sv */ 332 gv = kGVOP_gv; 332 if (GvSTASH(gv) != PL_curstash) ###### return; 332 gvname = GvNAME(gv); 332 if ( descending ? !(*gvname == 'a' && gvname[1] == '\0') : !(*gvname == 'b' && gvname[1] == '\0')) 332 return; 332 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); 332 if (descending) 31 o->op_private |= OPpSORT_DESCEND; 332 if (k->op_type == OP_NCMP) 304 o->op_private |= OPpSORT_NUMERIC; 332 if (k->op_type == OP_I_NCMP) 2 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; 332 kid = cLISTOPo->op_first->op_sibling; 332 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ 332 op_free(kid); /* then delete it */ } OP * Perl_ck_split(pTHX_ OP *o) 8432 { dVAR; 8432 register OP *kid; 8432 if (o->op_flags & OPf_STACKED) ###### return no_fh_allowed(o); 8432 kid = cLISTOPo->op_first; 8432 if (kid->op_type != OP_NULL) ###### Perl_croak(aTHX_ "panic: ck_split"); 8432 kid = kid->op_sibling; 8432 op_free(cLISTOPo->op_first); 8432 cLISTOPo->op_first = kid; 8432 if (!kid) { 80 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1)); 80 cLISTOPo->op_last = kid; /* There was only one element previously */ } 8432 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { 2068 OP *sibl = kid->op_sibling; 2068 kid->op_sibling = 0; 2068 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0); 2068 if (cLISTOPo->op_first == cLISTOPo->op_last) 101 cLISTOPo->op_last = kid; 2068 cLISTOPo->op_first = kid; 2068 kid->op_sibling = sibl; } 8432 kid->op_type = OP_PUSHRE; 8432 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE]; 8432 scalar(kid); 8432 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { 1 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /g modifier is meaningless in split"); } 8432 if (!kid->op_sibling) 336 append_elem(OP_SPLIT, o, newDEFSVOP()); 8432 kid = kid->op_sibling; 8432 scalar(kid); 8432 if (!kid->op_sibling) 7596 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); 8432 kid = kid->op_sibling; 8432 scalar(kid); 8432 if (kid->op_sibling) ###### return too_many_arguments(o,OP_DESC(o)); 8432 return o; } OP * Perl_ck_join(pTHX_ OP *o) 25445 { 25445 if (ckWARN(WARN_SYNTAX)) { 9940 const OP *kid = cLISTOPo->op_first->op_sibling; 9940 if (kid && kid->op_type == OP_MATCH) { 1 const REGEXP *re = PM_GETRE(kPMOP); 1 const char *pmstr = re ? re->precomp : "STRING"; 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "/%s/ should probably be written as \"%s\"", pmstr, pmstr); } } 25445 return ck_fun(o); } OP * Perl_ck_subr(pTHX_ OP *o) 604077 { 604077 OP *prev = ((cUNOPo->op_first->op_sibling) 604077 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first; 604077 OP *o2 = prev->op_sibling; 604077 OP *cvop; 604077 char *proto = 0; 604077 CV *cv = 0; 604077 GV *namegv = 0; 604077 int optional = 0; 604077 I32 arg = 0; 604077 I32 contextclass = 0; 604077 char *e = 0; 604077 bool delete_op = 0; 604077 o->op_private |= OPpENTERSUB_HASTARG; 604077 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; 604077 if (cvop->op_type == OP_RV2CV) { 345118 SVOP* tmpop; 345118 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); 345118 op_null(cvop); /* disable rv2cv */ 345118 tmpop = (SVOP*)((UNOP*)cvop)->op_first; 345118 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) { 275456 GV *gv = cGVOPx_gv(tmpop); 275456 cv = GvCVu(gv); 275456 if (!cv) 79163 tmpop->op_private |= OPpEARLY_CV; else { 196293 if (SvPOK(cv)) { 25849 namegv = CvANON(cv) ? gv : CvGV(cv); 25849 proto = SvPV_nolen((SV*)cv); } 196293 if (CvASSERTION(cv)) { 16 if (PL_hints & HINT_ASSERTING) { 9 if (PERLDB_ASSERTION && PL_curstash != PL_debstash) ###### o->op_private |= OPpENTERSUB_DB; } else { 7 delete_op = 1; 7 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) { ###### Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS), "Impossible to activate assertion call"); } } } } } } 258959 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) { 258606 if (o2->op_type == OP_CONST) 77396 o2->op_private &= ~OPpCONST_STRICT; 181210 else if (o2->op_type == OP_LIST) { ###### OP *o = ((UNOP*)o2)->op_first->op_sibling; ###### if (o && o->op_type == OP_CONST) ###### o->op_private &= ~OPpCONST_STRICT; } } 604077 o->op_private |= (PL_hints & HINT_STRICT_REFS); 604077 if (PERLDB_SUB && PL_curstash != PL_debstash) 197 o->op_private |= OPpENTERSUB_DB; 1504121 while (o2 != cvop) { 900047 if (proto) { 57337 switch (*proto) { case '\0': 3 return too_many_arguments(o, gv_ename(namegv)); case ';': 10932 optional = 1; 10932 proto++; 10932 continue; case '$': 42231 proto++; 42231 arg++; 42231 scalar(o2); 42231 break; case '%': case '@': 3181 list(o2); 3181 arg++; 3181 break; case '&': 462 proto++; 462 arg++; 462 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF) 1 bad_type(arg, arg == 1 ? "block or sub {}" : "sub {}", gv_ename(namegv), o2); 1 break; case '*': /* '*' allows any scalar type, including bareword */ 68 proto++; 68 arg++; 68 if (o2->op_type == OP_RV2GV) 7 goto wrapref; /* autoconvert GLOB -> GLOBref */ 61 else if (o2->op_type == OP_CONST) 33 o2->op_private &= ~OPpCONST_STRICT; 28 else if (o2->op_type == OP_ENTERSUB) { /* accidental subroutine, revert to bareword */ 4 OP *gvop = ((UNOP*)o2)->op_first; 4 if (gvop && gvop->op_type == OP_NULL) { 4 gvop = ((UNOP*)gvop)->op_first; 4 if (gvop) { 8 for (; gvop->op_sibling; gvop = gvop->op_sibling) ; 4 if (gvop && (gvop->op_private & OPpENTERSUB_NOPAREN) && (gvop = ((UNOP*)gvop)->op_first) && gvop->op_type == OP_GV) { 2 GV *gv = cGVOPx_gv(gvop); 2 OP *sibling = o2->op_sibling; 2 SV *n = newSVpvn("",0); 2 op_free(o2); 2 gv_fullname4(n, gv, "", FALSE); 2 o2 = newSVOP(OP_CONST, 0, n); 2 prev->op_sibling = o2; 2 o2->op_sibling = sibling; } } } } 61 scalar(o2); 61 break; case '[': case ']': 460 goto oops; 460 break; case '\\': 460 proto++; 460 arg++; again: 624 switch (*proto++) { case '[': 91 if (contextclass++ == 0) { 91 e = strchr(proto, ']'); 91 if (!e || e == proto) 5 goto oops; } else 5 goto oops; 5 goto again; 5 break; case ']': 5 if (contextclass) { 5 char *p = proto; 5 const char s = *p; 5 contextclass = 0; 5 *p = '\0'; 20 while (*--p != '['); 5 bad_type(arg, Perl_form(aTHX_ "one of %s", p), gv_ename(namegv), o2); 5 *proto = s; } else 2 goto oops; 2 break; case '*': 2 if (o2->op_type == OP_RV2GV) 1 goto wrapref; 1 if (!contextclass) ###### bad_type(arg, "symbol", gv_ename(namegv), o2); ###### break; case '&': 5 if (o2->op_type == OP_ENTERSUB) 2 goto wrapref; 3 if (!contextclass) 1 bad_type(arg, "subroutine entry", gv_ename(namegv), o2); 1 break; case '$': 392 if (o2->op_type == OP_RV2SV || o2->op_type == OP_PADSV || o2->op_type == OP_HELEM || o2->op_type == OP_AELEM || o2->op_type == OP_THREADSV) 50 goto wrapref; 50 if (!contextclass) ###### bad_type(arg, "scalar", gv_ename(namegv), o2); ###### break; case '@': 23 if (o2->op_type == OP_RV2AV || o2->op_type == OP_PADAV) 10 goto wrapref; 10 if (!contextclass) ###### bad_type(arg, "array", gv_ename(namegv), o2); ###### break; case '%': 106 if (o2->op_type == OP_RV2HV || o2->op_type == OP_PADHV) 10 goto wrapref; 10 if (!contextclass) ###### bad_type(arg, "hash", gv_ename(namegv), o2); ###### break; wrapref: { 461 OP* kid = o2; 461 OP* sib = kid->op_sibling; 461 kid->op_sibling = 0; 461 o2 = newUNOP(OP_REFGEN, 0, kid); 461 o2->op_sibling = sib; 461 prev->op_sibling = o2; } 461 if (contextclass && e) { 86 proto = e + 1; 86 contextclass = 0; } break; 540 default: goto oops; } 540 if (contextclass) 73 goto again; ###### break; case ' ': ###### proto++; ###### continue; default: oops: ###### Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf, gv_ename(namegv), cv); } } else 842710 list(o2); 889112 mod(o2, OP_ENTERSUB); 889112 prev = o2; 889112 o2 = o2->op_sibling; } 604074 if (proto && !optional && (*proto && *proto != '@' && *proto != '%' && *proto != ';')) 14 return too_few_arguments(o, gv_ename(namegv)); 604060 if(delete_op) { 7 op_free(o); 7 o=newSVOP(OP_CONST, 0, newSViv(0)); } 604060 return o; } OP * Perl_ck_svconst(pTHX_ OP *o) 5367081 { 5367081 SvREADONLY_on(cSVOPo->op_sv); 5367081 return o; } OP * Perl_ck_trunc(pTHX_ OP *o) 147 { 147 if (o->op_flags & OPf_KIDS) { 147 SVOP *kid = (SVOP*)cUNOPo->op_first; 147 if (kid->op_type == OP_NULL) 147 kid = (SVOP*)kid->op_sibling; 147 if (kid && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 12 o->op_flags |= OPf_SPECIAL; 12 kid->op_private &= ~OPpCONST_STRICT; } } 147 return ck_fun(o); } OP * Perl_ck_unpack(pTHX_ OP *o) 1548 { 1548 OP *kid = cLISTOPo->op_first; 1548 if (kid->op_sibling) { 1548 kid = kid->op_sibling; 1548 if (!kid->op_sibling) 1 kid->op_sibling = newDEFSVOP(); } 1548 return ck_fun(o); } OP * Perl_ck_substr(pTHX_ OP *o) 11429 { 11429 o = ck_fun(o); 11429 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) { 277 OP *kid = cLISTOPo->op_first; 277 if (kid->op_type == OP_NULL) 277 kid = kid->op_sibling; 277 if (kid) 277 kid->op_flags |= OPf_MOD; } 11429 return o; } /* A peephole optimizer. We visit the ops in the order they're to execute. * See the comments at the top of this file for more details about when * peep() is called */ void Perl_peep(pTHX_ register OP *o) 1618753 { dVAR; 1618753 register OP* oldop = 0; 1618753 if (!o || o->op_opt) 1237328 return; 1237328 ENTER; 1237328 SAVEOP(); 1237328 SAVEVPTR(PL_curcop); 47305436 for (; o; o = o->op_next) { 23891968 if (o->op_opt) 857910 break; 23034058 PL_op = o; 23034058 switch (o->op_type) { case OP_SETSTATE: case OP_NEXTSTATE: case OP_DBSTATE: 2217112 PL_curcop = ((COP*)o); /* for warnings */ 2217112 o->op_opt = 1; 2217112 break; case OP_CONST: 2972483 if (cSVOPo->op_private & OPpCONST_STRICT) 52 no_bareword_allowed(o); #ifdef USE_ITHREADS case OP_METHOD_NAMED: /* Relocate sv to the pad for thread safety. * Despite being a "constant", the SV is written to, * for reference counts, sv_upgrade() etc. */ if (cSVOP->op_sv) { const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) { /* If op_sv is already a PADTMP then it is being used by * some pad, so make a copy. */ sv_setsv(PAD_SVl(ix),cSVOPo->op_sv); SvREADONLY_on(PAD_SVl(ix)); SvREFCNT_dec(cSVOPo->op_sv); } else { SvREFCNT_dec(PAD_SVl(ix)); SvPADTMP_on(cSVOPo->op_sv); PAD_SETSV(ix, cSVOPo->op_sv); /* XXX I don't know how this isn't readonly already. */ SvREADONLY_on(PAD_SVl(ix)); } cSVOPo->op_sv = Nullsv; o->op_targ = ix; } #endif 2972483 o->op_opt = 1; 2972483 break; case OP_CONCAT: 512716 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { 176308 if (o->op_next->op_private & OPpTARGET_MY) { 11852 if (o->op_flags & OPf_STACKED) /* chained concats */ 6125 goto ignore_optimization; else { /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ 5727 o->op_targ = o->op_next->op_targ; 5727 o->op_next->op_targ = 0; 5727 o->op_private |= OPpTARGET_MY; } } 170183 op_null(o->op_next); } ignore_optimization: 512716 o->op_opt = 1; 512716 break; case OP_STUB: 19122 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { 7651 o->op_opt = 1; 7651 break; /* Scalar stub must produce undef. List stub is noop */ } 3720294 goto nothin; case OP_NULL: 3720294 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE || o->op_targ == OP_SETSTATE) { 76987 PL_curcop = ((COP*)o); } /* XXX: We avoid setting op_seq here to prevent later calls to peep() from mistakenly concluding that optimisation has already occurred. This doesn't fix the real problem, though (See 20010220.007). AMS 20010719 */ /* op_seq functionality is now replaced by op_opt */ 3720294 if (oldop && o->op_next) { 3710500 oldop->op_next = o->op_next; 3710500 continue; } 611471 break; case OP_SCALAR: case OP_LINESEQ: case OP_SCOPE: nothin: 611471 if (oldop && o->op_next) { 603878 oldop->op_next = o->op_next; 603878 continue; } 7593 o->op_opt = 1; 7593 break; case OP_PADAV: case OP_GV: 1613669 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { 583523 OP* pop = (o->op_type == OP_PADAV) ? 583523 o->op_next : o->op_next->op_next; 583523 IV i; 583523 if (pop && pop->op_type == OP_CONST && ((PL_op = pop->op_next)) && pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase) <= 255 && i >= 0) { 75252 GV *gv; 75252 if (cSVOPx(pop)->op_private & OPpCONST_STRICT) 2 no_bareword_allowed(pop); 75252 if (o->op_type == OP_GV) 59854 op_null(o->op_next); 75252 op_null(pop->op_next); 75252 op_null(pop); 75252 o->op_flags |= pop->op_next->op_flags & OPf_MOD; 75252 o->op_next = pop->op_next->op_next; 75252 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; 75252 o->op_private = (U8)i; 75252 if (o->op_type == OP_GV) { 59854 gv = cGVOPo_gv; 59854 GvAVn(gv); } else 15398 o->op_flags |= OPf_SPECIAL; 75252 o->op_type = OP_AELEMFAST; } 583523 o->op_opt = 1; 583523 break; } 1030146 if (o->op_next->op_type == OP_RV2SV) { 518544 if (!(o->op_next->op_private & OPpDEREF)) { 514556 op_null(o->op_next); 514556 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO | OPpOUR_INTRO); 514556 o->op_next = o->op_next->op_next; 514556 o->op_type = OP_GVSV; 514556 o->op_ppaddr = PL_ppaddr[OP_GVSV]; } } 511602 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { 33126 GV *gv = cGVOPo_gv; 33126 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) { /* XXX could check prototype here instead of just carping */ 1 SV *sv = sv_newmortal(); 1 gv_efullname3(sv, gv, Nullch); 1 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf"() called too early to check prototype", sv); } } 478476 else if (o->op_next->op_type == OP_READLINE && o->op_next->op_next->op_type == OP_CONCAT && (o->op_next->op_next->op_flags & OPf_STACKED)) { /* Turn "$a .= " into an OP_RCATLINE. AMS 20010917 */ 13 o->op_type = OP_RCATLINE; 13 o->op_flags |= OPf_STACKED; 13 o->op_ppaddr = PL_ppaddr[OP_RCATLINE]; 13 op_null(o->op_next->op_next); 13 op_null(o->op_next); } 1030146 o->op_opt = 1; 1030146 break; case OP_MAPWHILE: case OP_GREPWHILE: case OP_AND: case OP_OR: case OP_DOR: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: case OP_COND_EXPR: case OP_RANGE: 857042 o->op_opt = 1; 973992 while (cLOGOP->op_other->op_type == OP_NULL) 116950 cLOGOP->op_other = cLOGOP->op_other->op_next; 857042 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ 857042 break; case OP_ENTERLOOP: case OP_ENTERITER: 81179 o->op_opt = 1; 83055 while (cLOOP->op_redoop->op_type == OP_NULL) 1876 cLOOP->op_redoop = cLOOP->op_redoop->op_next; 81179 peep(cLOOP->op_redoop); 81214 while (cLOOP->op_nextop->op_type == OP_NULL) 35 cLOOP->op_nextop = cLOOP->op_nextop->op_next; 81179 peep(cLOOP->op_nextop); 81179 while (cLOOP->op_lastop->op_type == OP_NULL) ###### cLOOP->op_lastop = cLOOP->op_lastop->op_next; 81179 peep(cLOOP->op_lastop); 81179 break; case OP_QR: case OP_MATCH: case OP_SUBST: 151487 o->op_opt = 1; 154980 while (cPMOP->op_pmreplstart && cPMOP->op_pmreplstart->op_type == OP_NULL) 3493 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next; 151487 peep(cPMOP->op_pmreplstart); 151487 break; case OP_EXEC: 193 o->op_opt = 1; 193 if (ckWARN(WARN_SYNTAX) && o->op_next && o->op_next->op_type == OP_NEXTSTATE) { 1 if (o->op_next->op_sibling && o->op_next->op_sibling->op_type != OP_EXIT && o->op_next->op_sibling->op_type != OP_WARN && o->op_next->op_sibling->op_type != OP_DIE) { 1 const line_t oldline = CopLINE(PL_curcop); 1 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next)); 1 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Statement unlikely to be reached"); 1 Perl_warner(aTHX_ packWARN(WARN_EXEC), "\t(Maybe you meant system() when you said exec()?)\n"); 1 CopLINE_set(PL_curcop, oldline); } } 1 break; case OP_HELEM: { 337922 UNOP *rop; 337922 SV *lexname; 337922 GV **fields; 337922 SV **svp, *sv; 337922 const char *key = NULL; 337922 STRLEN keylen; 337922 o->op_opt = 1; 337922 if (((BINOP*)o)->op_last->op_type != OP_CONST) 86621 break; /* Make the CONST have a shared SV */ 251301 svp = cSVOPx_svp(((BINOP*)o)->op_last); 251301 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { 251301 key = SvPV_const(sv, keylen); 251301 lexname = newSVpvn_share(key, SvUTF8(sv) ? -(I32)keylen : keylen, 0); 251301 SvREFCNT_dec(sv); 251301 *svp = lexname; } 251301 if ((o->op_private & (OPpLVAL_INTRO))) 6188 break; 245113 rop = (UNOP*)((BINOP*)o)->op_first; 245113 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) 150245 break; 150245 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); 150245 if (!(SvFLAGS(lexname) & SVpad_TYPED)) 150227 break; 18 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); 18 if (!fields || !GvHV(*fields)) ###### break; 18 key = SvPV_const(*svp, keylen); 18 if (!hv_fetch(GvHV(*fields), key, SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE)) { 2 Perl_croak(aTHX_ "No such class field \"%s\" " "in variable %s of type %s", key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname))); } 7959 break; } case OP_HSLICE: { 7959 UNOP *rop; 7959 SV *lexname; 7959 GV **fields; 7959 SV **svp; 7959 const char *key; 7959 STRLEN keylen; 7959 SVOP *first_key_op, *key_op; 7959 if ((o->op_private & (OPpLVAL_INTRO)) /* I bet there's always a pushmark... */ || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST) /* hmmm, no optimization if list contains only one key. */ 3776 break; 3776 rop = (UNOP*)((LISTOP*)o)->op_last; 3776 if (rop->op_type != OP_RV2HV) 2173 break; 1603 if (rop->op_first->op_type == OP_PADSV) /* @$hash{qw(keys here)} */ 701 rop = (UNOP*)rop->op_first; else { /* @{$hash}{qw(keys here)} */ 902 if (rop->op_first->op_type == OP_SCOPE && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV) { 294 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last; } else 995 break; } 995 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE); 995 if (!(SvFLAGS(lexname) & SVpad_TYPED)) 990 break; 5 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); 5 if (!fields || !GvHV(*fields)) ###### break; /* Again guessing that the pushmark can be jumped over.... */ 5 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling) ->op_first->op_sibling; 14 for (key_op = first_key_op; key_op; key_op = (SVOP*)key_op->op_sibling) { 11 if (key_op->op_type != OP_CONST) 2 continue; 9 svp = cSVOPx_svp(key_op); 9 key = SvPV_const(*svp, keylen); 9 if (!hv_fetch(GvHV(*fields), key, SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE)) { 2 Perl_croak(aTHX_ "No such class field \"%s\" " "in variable %s of type %s", key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname))); } } 5416 break; } case OP_SORT: { /* will point to RV2AV or PADAV op on LHS/RHS of assign */ 5416 OP *oleft, *oright; 5416 OP *o2; /* check that RHS of sort is a single plain array */ 5416 oright = cUNOPo->op_first; 5416 if (!oright || oright->op_type != OP_PUSHMARK) 5416 break; /* reverse sort ... can be optimised. */ 5416 if (!cUNOPo->op_sibling) { /* Nothing follows us on the list. */ 5155 OP *reverse = o->op_next; 5155 if (reverse->op_type == OP_REVERSE && (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { 75 OP *pushmark = cUNOPx(reverse)->op_first; 75 if (pushmark && (pushmark->op_type == OP_PUSHMARK) && (cUNOPx(pushmark)->op_sibling == o)) { /* reverse -> pushmark -> sort */ 74 o->op_private |= OPpSORT_REVERSE; 74 op_null(reverse); 74 pushmark->op_next = oright->op_next; 74 op_null(oright); } } } /* make @a = sort @a act in-place */ 5416 o->op_opt = 1; 5416 oright = cUNOPx(oright)->op_sibling; 5416 if (!oright) ###### break; 5416 if (oright->op_type == OP_NULL) { /* skip sort block/sub */ 1527 oright = cUNOPx(oright)->op_sibling; } 5416 if (!oright || (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV) || oright->op_next != o || (oright->op_private & OPpLVAL_INTRO) ) 1685 break; /* o2 follows the chain of op_nexts through the LHS of the * assign (if any) to the aassign op itself */ 1685 o2 = o->op_next; 1685 if (!o2 || o2->op_type != OP_NULL) 228 break; 228 o2 = o2->op_next; 228 if (!o2 || o2->op_type != OP_PUSHMARK) 139 break; 139 o2 = o2->op_next; 139 if (o2 && o2->op_type == OP_GV) 48 o2 = o2->op_next; 139 if (!o2 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV) || (o2->op_private & OPpLVAL_INTRO) ) 121 break; 121 oleft = o2; 121 o2 = o2->op_next; 121 if (!o2 || o2->op_type != OP_NULL) 121 break; 121 o2 = o2->op_next; 121 if (!o2 || o2->op_type != OP_AASSIGN || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID) 104 break; /* check that the sort is the first arg on RHS of assign */ 104 o2 = cUNOPx(o2)->op_first; 104 if (!o2 || o2->op_type != OP_NULL) 104 break; 104 o2 = cUNOPx(o2)->op_first; 104 if (!o2 || o2->op_type != OP_PUSHMARK) 104 break; 104 if (o2->op_sibling != o) 5 break; /* check the array is the same on both sides */ 99 if (oleft->op_type == OP_RV2AV) { 30 if (oright->op_type != OP_RV2AV || !cUNOPx(oright)->op_first || cUNOPx(oright)->op_first->op_type != OP_GV || cGVOPx_gv(cUNOPx(oleft)->op_first) != cGVOPx_gv(cUNOPx(oright)->op_first) ) 69 break; } 69 else if (oright->op_type != OP_PADAV || oright->op_targ != oleft->op_targ ) 54 break; /* transfer MODishness etc from LHS arg to RHS arg */ 54 oright->op_flags = oleft->op_flags; 54 o->op_private |= OPpSORT_INPLACE; /* excise push->gv->rv2av->null->aassign */ 54 o2 = o->op_next->op_next; 54 op_null(o2); /* PUSHMARK */ 54 o2 = o2->op_next; 54 if (o2->op_type == OP_GV) { 16 op_null(o2); /* GV */ 16 o2 = o2->op_next; } 54 op_null(o2); /* RV2AV or PADAV */ 54 o2 = o2->op_next->op_next; 54 op_null(o2); /* AASSIGN */ 54 o->op_next = o2->op_next; 54 break; } case OP_REVERSE: { 1058 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; 1058 OP *gvop = NULL; 1058 LISTOP *enter, *exlist; 1058 o->op_opt = 1; 1058 enter = (LISTOP *) o->op_next; 1058 if (!enter) ###### break; 1058 if (enter->op_type == OP_NULL) { 677 enter = (LISTOP *) enter->op_next; 677 if (!enter) ###### break; } /* for $a (...) will have OP_GV then OP_RV2GV here. for (...) just has an OP_GV. */ 1058 if (enter->op_type == OP_GV) { 93 gvop = (OP *) enter; 93 enter = (LISTOP *) enter->op_next; 93 if (!enter) ###### break; 93 if (enter->op_type == OP_RV2GV) { 18 enter = (LISTOP *) enter->op_next; 18 if (!enter) ###### break; } } 1058 if (enter->op_type != OP_ENTERITER) 781 break; 277 iter = enter->op_next; 277 if (!iter || iter->op_type != OP_ITER) 277 break; 277 expushmark = enter->op_first; 277 if (!expushmark || expushmark->op_type != OP_NULL || expushmark->op_targ != OP_PUSHMARK) 277 break; 277 exlist = (LISTOP *) expushmark->op_sibling; 277 if (!exlist || exlist->op_type != OP_NULL || exlist->op_targ != OP_LIST) 277 break; 277 if (exlist->op_last != o) { /* Mmm. Was expecting to point back to this op. */ ###### break; } 277 theirmark = exlist->op_first; 277 if (!theirmark || theirmark->op_type != OP_PUSHMARK) 277 break; 277 if (theirmark->op_sibling != o) { /* There's something between the mark and the reverse, eg for (1, reverse (...)) so no go. */ 12 break; } 265 ourmark = ((LISTOP *)o)->op_first; 265 if (!ourmark || ourmark->op_type != OP_PUSHMARK) 265 break; 265 ourlast = ((LISTOP *)o)->op_last; 265 if (!ourlast || ourlast->op_next != o) 265 break; 265 rv2av = ourmark->op_sibling; 265 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS) && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) { /* We're just reversing a single array. */ 200 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF; 200 enter->op_flags |= OPf_STACKED; } /* We don't have control over who points to theirmark, so sacrifice ours. */ 265 theirmark->op_next = ourmark->op_next; 265 theirmark->op_flags = ourmark->op_flags; 265 ourlast->op_next = gvop ? gvop : (OP *) enter; 265 op_null(ourmark); 265 op_null(o); 265 enter->op_private |= OPpITER_REVERSED; 265 iter->op_private |= OPpITER_REVERSED; 265 break; } default: 9936406 o->op_opt = 1; 18719676 break; } 18719676 oldop = o; } 1237324 LEAVE; } char* Perl_custom_op_name(pTHX_ const OP* o) ###### { ###### const IV index = PTR2IV(o->op_ppaddr); ###### SV* keysv; ###### HE* he; ###### if (!PL_custom_op_names) /* This probably shouldn't happen */ ###### return (char *)PL_op_name[OP_CUSTOM]; ###### keysv = sv_2mortal(newSViv(index)); ###### he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0); ###### if (!he) ###### return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */ ###### return SvPV_nolen(HeVAL(he)); } char* Perl_custom_op_desc(pTHX_ const OP* o) ###### { ###### const IV index = PTR2IV(o->op_ppaddr); ###### SV* keysv; ###### HE* he; ###### if (!PL_custom_op_descs) ###### return (char *)PL_op_desc[OP_CUSTOM]; ###### keysv = sv_2mortal(newSViv(index)); ###### he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0); ###### if (!he) ###### return (char *)PL_op_desc[OP_CUSTOM]; ###### return SvPV_nolen(HeVAL(he)); } #include "XSUB.h" /* Efficient sub that returns a constant scalar value. */ static void const_sv_xsub(pTHX_ CV* cv) 38099 { 38099 dXSARGS; 38099 if (items != 0) { #if 0 Perl_croak(aTHX_ "usage: %s::%s()", HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); #endif } 38099 EXTEND(sp, 1); 38099 ST(0) = (SV*)XSANY.any_ptr; 38099 XSRETURN(1); } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */