/* 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) ###### { ###### SV* tmpsv = sv_newmortal(); ###### gv_efullname3(tmpsv, gv, Nullch); ###### 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) ###### { ###### yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name)); ###### return o; } STATIC OP * S_too_many_arguments(pTHX_ OP *o, const char *name) ###### { ###### yyerror(Perl_form(aTHX_ "Too many arguments for %s", name)); ###### return o; } STATIC void S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid) ###### { ###### 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) ###### { ###### qerror(Perl_mess(aTHX_ "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", cSVOPo_sv)); } /* "register" allocation */ PADOFFSET Perl_allocmy(pTHX_ char *name) 214565 { 214565 PADOFFSET off; /* complain about "my $" etc etc */ 214565 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)))) { ###### if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { /* 1999-02-27 mjd@plover.com */ ###### char *p; ###### 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. */ ###### if (p-name > 200) { ###### strcpy(name+200, "..."); ###### p = name+199; } else { ###### p[1] = '\0'; } /* Move everything else down one character */ ###### for (; p-name > 2; p--) ###### *p = *(p-1); ###### name[2] = toCTRL(name[1]); ###### name[1] = '^'; } ###### yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name)); } /* check for duplicate declaration */ 214565 pad_check_dup(name, (bool)(PL_in_my == KEY_our), (PL_curstash ? PL_curstash : PL_defstash) ); 214565 if (PL_in_my_stash && *name != '$') { ###### 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 */ 214565 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 */ ); 214565 return off; } /* Destructor */ void Perl_op_free(pTHX_ OP *o) 8496069 { dVAR; 8496069 OPCODE type; 8496069 PADOFFSET refcnt; 8496069 if (!o || o->op_static) 8477959 return; 8477959 if (o->op_private & OPpREFCOUNTED) { 508618 switch (o->op_type) { case OP_LEAVESUB: case OP_LEAVESUBLV: case OP_LEAVEEVAL: case OP_LEAVE: case OP_SCOPE: case OP_LEAVEWRITE: 102500 OP_REFCNT_LOCK; 102500 refcnt = OpREFCNT_dec(o); 102500 OP_REFCNT_UNLOCK; 102500 if (refcnt) 2948 return; 8475011 break; default: 8475011 break; } } 8475011 if (o->op_flags & OPf_KIDS) { 3855089 register OP *kid, *nextkid; 11800215 for (kid = cUNOPo->op_first; kid; kid = nextkid) { 7945126 nextkid = kid->op_sibling; /* Get before next freeing kid */ 7945126 op_free(kid); } } 8475011 type = o->op_type; 8475011 if (type == OP_NULL) 1439759 type = (OPCODE)o->op_targ; /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ 8475011 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) 830221 cop_free((COP*)o); 8475011 op_clear(o); 8475011 FreeOp(o); #ifdef DEBUG_LEAKING_SCALARS if (PL_op == o) PL_op = Nullop; #endif } void Perl_op_clear(pTHX_ OP *o) 9545920 { dVAR; 9545920 switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ case OP_ENTEREVAL: /* Was holding hints. */ 1445689 o->op_targ = 0; 1445689 break; default: 6185245 if (!(o->op_flags & OPf_REF) || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst))) 539497 break; /* FALL THROUGH */ case OP_GVSV: case OP_GV: case OP_AELEMFAST: 539497 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 533191 SvREFCNT_dec(cSVOPo->op_sv); 533191 cSVOPo->op_sv = Nullsv; #endif } 533191 break; case OP_METHOD_NAMED: case OP_CONST: 1273570 SvREFCNT_dec(cSVOPo->op_sv); 1273570 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 1273570 break; case OP_GOTO: case OP_NEXT: case OP_LAST: case OP_REDO: 34124 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) 26735 break; /* FALL THROUGH */ case OP_TRANS: 8706 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { ###### SvREFCNT_dec(cSVOPo->op_sv); ###### cSVOPo->op_sv = Nullsv; } else { 8706 Safefree(cPVOPo->op_pv); 8706 cPVOPo->op_pv = Nullch; } 8706 break; case OP_SUBST: 24068 op_free(cPMOPo->op_pmreplroot); 24068 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 4498 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot); #endif /* FALL THROUGH */ case OP_MATCH: case OP_QR: clear_pmop: { 70148 HV *pmstash = PmopSTASH(cPMOPo); 70148 if (pmstash && SvREFCNT(pmstash)) { 61277 MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); 61277 if (mg) { 61277 PMOP *pmop = (PMOP*) mg->mg_obj; 61277 PMOP *lastpmop = NULL; 533326 while (pmop) { 533326 if (cPMOPo == pmop) { 61277 if (lastpmop) 51093 lastpmop->op_pmnext = pmop->op_pmnext; else 10184 mg->mg_obj = (SV*) pmop->op_pmnext; 10184 break; } 472049 lastpmop = pmop; 472049 pmop = pmop->op_pmnext; } } } PmopSTASH_free(cPMOPo); } 70148 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 */ 70148 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo)); 70148 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 9545920 break; } 9545920 if (o->op_targ > 0) { 1897618 pad_free(o->op_targ); 1897618 o->op_targ = 0; } } STATIC void S_cop_free(pTHX_ COP* cop) 830221 { 830221 Safefree(cop->cop_label); /* FIXME: treaddead ??? */ 830221 CopFILE_free(cop); CopSTASH_free(cop); 830221 if (! specialWARN(cop->cop_warnings)) 182 SvREFCNT_dec(cop->cop_warnings); 830221 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 ###### SvREFCNT_dec(cop->cop_io); #endif } } void Perl_op_null(pTHX_ OP *o) 1070909 { dVAR; 1070909 if (o->op_type == OP_NULL) ###### return; 1070909 op_clear(o); 1070909 o->op_targ = o->op_type; 1070909 o->op_type = OP_NULL; 1070909 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) 3362819 { 3362819 if (o->op_next) 8668 return o->op_next; /* establish postfix order */ 3354151 if (cUNOPo->op_first) { 3341852 register OP *kid; 3341852 o->op_next = LINKLIST(cUNOPo->op_first); 10381749 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 7039897 if (kid->op_sibling) 3698045 kid->op_next = LINKLIST(kid->op_sibling); else 3341852 kid->op_next = o; } } else 12299 o->op_next = o; 3354151 return o->op_next; } OP * Perl_scalarkids(pTHX_ OP *o) 1655 { 1655 if (o && o->op_flags & OPf_KIDS) { 1655 OP *kid; 3868 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 2213 scalar(kid); } 1655 return o; } STATIC OP * S_scalarboolean(pTHX_ OP *o) 343036 { 343036 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { ###### if (ckWARN(WARN_SYNTAX)) { ###### const line_t oldline = CopLINE(PL_curcop); ###### if (PL_copline != NOLINE) ###### CopLINE_set(PL_curcop, PL_copline); ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); ###### CopLINE_set(PL_curcop, oldline); } } 343036 return scalar(o); } OP * Perl_scalar(pTHX_ OP *o) 11559336 { dVAR; 11559336 OP *kid; /* assumes no premature commitment */ 11559336 if (!o || (o->op_flags & OPf_WANT) || PL_error_count || o->op_type == OP_RETURN) { 6093061 return o; } 5466275 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; 5466275 switch (o->op_type) { case OP_REPEAT: 286 scalar(cBINOPo->op_first); 286 break; case OP_OR: case OP_AND: case OP_COND_EXPR: 187706 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 101502 scalar(kid); ###### break; case OP_SPLIT: ###### if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { ###### if (!kPMOP->op_pmreplroot) ###### deprecate_old("implicit split to @_"); } /* FALL THROUGH */ case OP_MATCH: case OP_QR: case OP_SUBST: case OP_NULL: default: 5314387 if (o->op_flags & OPf_KIDS) { 5164742 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 3182697 scalar(kid); } 3174 break; case OP_LEAVE: case OP_LEAVETRY: 3174 kid = cLISTOPo->op_first; 3174 scalar(kid); 12376 while ((kid = kid->op_sibling)) { 9202 if (kid->op_sibling) 6028 scalarvoid(kid); else 3174 scalar(kid); } 3174 WITH_THR(PL_curcop = &PL_compiling); 3174 break; case OP_SCOPE: case OP_LINESEQ: case OP_LIST: 419064 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 356840 if (kid->op_sibling) 294616 scalarvoid(kid); else 62224 scalar(kid); } 62224 WITH_THR(PL_curcop = &PL_compiling); 62224 break; case OP_SORT: ###### if (ckWARN(WARN_VOID)) ###### Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); } 5466275 return o; } OP * Perl_scalarvoid(pTHX_ OP *o) 3595521 { dVAR; 3595521 OP *kid; 3595521 const char* useless = 0; 3595521 SV* sv; 3595521 U8 want; 3595521 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))) 1632354 PL_curcop = (COP*)o; /* for warning below */ /* assumes no premature commitment */ 3595521 want = o->op_flags & OPf_WANT; 3595521 if ((want && want != OPf_WANT_SCALAR) || PL_error_count || o->op_type == OP_RETURN) { 1387323 return o; } 2208198 if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { 9982 return scalar(o); /* As if inside SASSIGN */ } 2198216 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 2198216 switch (o->op_type) { default: 493868 if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) 475021 break; /* FALL THROUGH */ case OP_REPEAT: 18847 if (o->op_flags & OPf_STACKED) 18847 break; ###### goto func_ops; case OP_SUBSTR: ###### if (o->op_private == 4) ###### 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: 40460 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) ###### useless = OP_DESC(o); ###### break; case OP_NOT: ###### kid = cUNOPo->op_first; ###### if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && kid->op_type != OP_TRANS) { ###### goto func_ops; } ###### useless = "negative pattern binding (!~)"; ###### break; case OP_RV2GV: case OP_RV2SV: case OP_RV2AV: case OP_RV2HV: 17489 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) ###### useless = "a variable"; ###### break; case OP_CONST: 143 sv = cSVOPo_sv; 143 if (cSVOPo->op_private & OPpCONST_STRICT) ###### no_bareword_allowed(o); else { 143 if (ckWARN(WARN_VOID)) { 59 useless = "a constant"; /* don't warn on optimised away booleans, eg * use constant Foo, 5; Foo || print; */ 59 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) 1 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; */ 58 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) 58 useless = 0; ###### 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. */ ###### if (strnEQ(SvPVX_const(sv), "di", 2) || strnEQ(SvPVX_const(sv), "ds", 2) || strnEQ(SvPVX_const(sv), "ig", 2)) ###### useless = 0; } } } 143 op_null(o); /* don't execute or even remember it */ 143 break; case OP_POSTINC: 3860 o->op_type = OP_PREINC; /* pre-increment is faster */ 3860 o->op_ppaddr = PL_ppaddr[OP_PREINC]; 3860 break; case OP_POSTDEC: 57 o->op_type = OP_PREDEC; /* pre-decrement is faster */ 57 o->op_ppaddr = PL_ppaddr[OP_PREDEC]; 57 break; case OP_OR: case OP_AND: case OP_DOR: case OP_COND_EXPR: 500899 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 272583 scalarvoid(kid); 239033 break; case OP_NULL: 239033 if (o->op_flags & OPf_STACKED) 1144 break; /* FALL THROUGH */ case OP_NEXTSTATE: case OP_DBSTATE: case OP_ENTERTRY: case OP_ENTER: 1146787 if (!(o->op_flags & OPf_KIDS)) 908898 break; /* FALL THROUGH */ case OP_SCOPE: case OP_LEAVE: case OP_LEAVETRY: case OP_LEAVELOOP: case OP_LINESEQ: case OP_LIST: 1557553 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1122992 scalarvoid(kid); 1376 break; case OP_ENTEREVAL: 1376 scalarkids(o); 1376 break; case OP_REQUIRE: /* all requires must return a boolean value */ 68040 o->op_flags &= ~OPf_WANT; /* FALL THROUGH */ case OP_SCALAR: 68040 return scalar(o); case OP_SPLIT: 4 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { 4 if (!kPMOP->op_pmreplroot) 1 deprecate_old("implicit split to @_"); } 2130176 break; } 2130176 if (useless && ckWARN(WARN_VOID)) ###### Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless); 2130176 return o; } OP * Perl_listkids(pTHX_ OP *o) 1000802 { 1000802 if (o && o->op_flags & OPf_KIDS) { 1000802 OP *kid; 3095875 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 2095073 list(kid); } 1000802 return o; } OP * Perl_list(pTHX_ OP *o) 2558464 { dVAR; 2558464 OP *kid; /* assumes no premature commitment */ 2558464 if (!o || (o->op_flags & OPf_WANT) || PL_error_count || o->op_type == OP_RETURN) { 1820523 return o; } 737941 if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { ###### return o; /* As if inside SASSIGN */ } 737941 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; 737941 switch (o->op_type) { case OP_FLOP: case OP_REPEAT: 1796 list(cBINOPo->op_first); 1796 break; case OP_OR: case OP_AND: case OP_COND_EXPR: 15451 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 10081 list(kid); 719009 break; default: case OP_MATCH: case OP_QR: case OP_SUBST: case OP_NULL: 719009 if (!(o->op_flags & OPf_KIDS)) 236331 break; 482678 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) { 178 list(cBINOPo->op_first); 178 return gen_constant_list(o); } case OP_LIST: 489519 listkids(o); 489519 break; case OP_LEAVE: case OP_LEAVETRY: 2291 kid = cLISTOPo->op_first; 2291 list(kid); 8151 while ((kid = kid->op_sibling)) { 5860 if (kid->op_sibling) 3569 scalarvoid(kid); else 2291 list(kid); } 2291 WITH_THR(PL_curcop = &PL_compiling); 2291 break; case OP_SCOPE: case OP_LINESEQ: 7368 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 4912 if (kid->op_sibling) 2456 scalarvoid(kid); else 2456 list(kid); } 2456 WITH_THR(PL_curcop = &PL_compiling); 2456 break; case OP_REQUIRE: /* all requires must return a boolean value */ ###### o->op_flags &= ~OPf_WANT; ###### return scalar(o); } 737763 return o; } OP * Perl_scalarseq(pTHX_ OP *o) 463400 { 463400 if (o) { 461737 if (o->op_type == OP_LINESEQ || o->op_type == OP_SCOPE || o->op_type == OP_LEAVE || o->op_type == OP_LEAVETRY) { 379131 OP *kid; 2649869 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 2270738 if (kid->op_sibling) { 1891607 scalarvoid(kid); } } 379131 PL_curcop = &PL_compiling; } 461737 o->op_flags &= ~OPf_PARENS; 461737 if (PL_hints & HINT_BLOCK_SCOPE) 364000 o->op_flags |= OPf_PARENS; } else 1663 o = newOP(OP_STUB, 0); 463400 return o; } STATIC OP * S_modkids(pTHX_ OP *o, I32 type) 86753 { 86753 if (o && o->op_flags & OPf_KIDS) { 80499 OP *kid; 160998 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 80499 mod(kid, type); } 86753 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) 1049380 { dVAR; 1049380 OP *kid; /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ 1049380 int localize = -1; 1049380 if (!o || PL_error_count) 34 return o; 1049346 if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { 42 return o; } 1049304 switch (o->op_type) { case OP_UNDEF: 978 localize = 0; 978 PL_modcount++; 978 return o; case OP_CONST: 88811 if (!(o->op_private & (OPpCONST_ARYBASE))) 88811 goto nomod; ###### if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { ###### PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv); ###### PL_eval_start = 0; } ###### else if (!type) { ###### SAVEI32(PL_compiling.cop_arybase); ###### PL_compiling.cop_arybase = 0; } ###### else if (type == OP_REFGEN) ###### goto nomod; else ###### Perl_croak(aTHX_ "That use of $[ is unsupported"); 622 break; case OP_STUB: 622 if (o->op_flags & OPf_PARENS) 622 break; 20076 goto nomod; case OP_ENTERSUB: 20076 if ((type == OP_UNDEF || type == OP_REFGEN) && !(o->op_flags & OPf_STACKED)) { 17027 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 17027 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 17027 assert(cUNOPo->op_first->op_type == OP_NULL); 17027 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ 17027 break; } 3049 else if (o->op_private & OPpENTERSUB_NOMOD) ###### return o; else { /* lvalue subroutine call */ 3049 o->op_private |= OPpLVAL_INTRO; 3049 PL_modcount = RETURN_UNLIMITED_NUMBER; 3049 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { /* Backward compatibility mode: */ 3049 o->op_private |= OPpENTERSUB_INARGS; 3049 break; } else { /* Compile-time error message: */ ###### OP *kid = cUNOPo->op_first; ###### CV *cv; ###### OP *okid; ###### if (kid->op_type == OP_PUSHMARK) ###### goto skip_kids; ###### 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); ###### kid = kLISTOP->op_first; skip_kids: ###### while (kid->op_sibling) ###### kid = kid->op_sibling; ###### if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { /* Indirect call */ ###### if (kid->op_type == OP_METHOD_NAMED || kid->op_type == OP_METHOD) { ###### UNOP *newop; ###### NewOp(1101, newop, 1, UNOP); ###### newop->op_type = OP_RV2CV; ###### newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; ###### newop->op_first = Nullop; ###### newop->op_next = (OP*)newop; ###### kid->op_sibling = (OP*)newop; ###### newop->op_private |= OPpLVAL_INTRO; ###### 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 */ } ###### okid = kid; ###### kid = kUNOP->op_first; ###### if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) ###### kid = kUNOP->op_first; ###### 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); ###### if (kid->op_type != OP_GV) { /* Restore RV2CV to check lvalueness */ restore_2cv: ###### if (kid->op_next && kid->op_next != kid) { /* Happens? */ ###### okid->op_next = kid->op_next; ###### kid->op_next = okid; } else ###### okid->op_next = Nullop; ###### okid->op_type = OP_RV2CV; ###### okid->op_targ = 0; ###### okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; ###### okid->op_private |= OPpLVAL_INTRO; ###### break; } ###### cv = GvCV(kGVOP_gv); ###### if (!cv) ###### goto restore_2cv; ###### if (CvLVALUE(cv)) ###### break; } } /* FALL THROUGH */ default: nomod: /* grep, foreach, subcalls, refgen */ 166892 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) ###### break; ###### 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")); ###### 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: 2599 if (!(o->op_flags & OPf_STACKED)) 1491 goto nomod; 1108 PL_modcount++; 1108 break; case OP_COND_EXPR: 1395 localize = 1; 4185 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 2790 mod(kid, type); 110130 break; case OP_RV2AV: case OP_RV2HV: 110130 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { 50 PL_modcount = RETURN_UNLIMITED_NUMBER; 50 return o; /* Treat \(@foo) like ordinary list. */ } /* FALL THROUGH */ case OP_RV2GV: 128856 if (scalar_mod_type(o, type)) ###### goto nomod; 128856 ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_ASLICE: case OP_HSLICE: 131366 if (type == OP_LEAVESUBLV) ###### o->op_private |= OPpMAYBE_LVSUB; 131366 localize = 1; /* FALL THROUGH */ case OP_AASSIGN: case OP_NEXTSTATE: case OP_DBSTATE: 131392 PL_modcount = RETURN_UNLIMITED_NUMBER; 131392 break; case OP_RV2SV: 76120 ref(cUNOPo->op_first, o->op_type); 76120 localize = 1; /* FALL THROUGH */ case OP_GV: case OP_AV2ARYLEN: 76282 PL_hints |= HINT_BLOCK_SCOPE; case OP_SASSIGN: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: 78282 PL_modcount++; 78282 break; case OP_AELEMFAST: ###### localize = -1; ###### PL_modcount++; ###### break; case OP_PADAV: case OP_PADHV: 57896 PL_modcount = RETURN_UNLIMITED_NUMBER; 57896 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) ###### return o; /* Treat \(@foo) like ordinary list. */ 57896 if (scalar_mod_type(o, type)) ###### goto nomod; 57896 if (type == OP_LEAVESUBLV) ###### o->op_private |= OPpMAYBE_LVSUB; /* FALL THROUGH */ case OP_PADSV: 408712 PL_modcount++; 408712 if (!type) /* local() */ ###### Perl_croak(aTHX_ "Can't localize lexical variable %s", PAD_COMPNAME_PV(o->op_targ)); 97343 break; case OP_PUSHMARK: 97343 localize = 0; 97343 break; case OP_KEYS: 1867 if (type != OP_SASSIGN) 1867 goto nomod; 482 goto lvalue_func; case OP_SUBSTR: 482 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ ###### goto nomod; /* FALL THROUGH */ case OP_POS: case OP_VEC: 2886 if (type == OP_LEAVESUBLV) ###### o->op_private |= OPpMAYBE_LVSUB; lvalue_func: 2886 pad_free(o->op_targ); 2886 o->op_targ = pad_alloc(o->op_type, SVs_PADMY); 2886 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL); 2886 if (o->op_flags & OPf_KIDS) 2886 mod(cBINOPo->op_first->op_sibling, type); 2886 break; case OP_AELEM: case OP_HELEM: 40722 ref(cBINOPo->op_first, o->op_type); 40722 if (type == OP_ENTERSUB && !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) 4894 o->op_private |= OPpLVAL_DEFER; 40722 if (type == OP_LEAVESUBLV) ###### o->op_private |= OPpMAYBE_LVSUB; 40722 localize = 1; 40722 PL_modcount++; 40722 break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: case OP_LINESEQ: ###### localize = 0; ###### if (o->op_flags & OPf_KIDS) ###### mod(cLISTOPo->op_last, type); ###### break; case OP_NULL: 66620 localize = 0; 66620 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ 1320 goto nomod; 65300 else if (!(o->op_flags & OPf_KIDS)) ###### break; 65300 if (o->op_targ != OP_LIST) { 1503 mod(cBINOPo->op_first, type); 1503 break; } /* FALL THROUGH */ case OP_LIST: 97343 localize = 0; 351236 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 253893 mod(kid, type); ###### break; case OP_RETURN: ###### if (type != OP_LEAVESUBLV) ###### goto nomod; 1048276 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 */ 1048276 if (type == OP_REFGEN && PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)) ###### return o; 1048276 if (type != OP_LEAVESUBLV) 1048276 o->op_flags |= OPf_MOD; 1048276 if (type == OP_AASSIGN || type == OP_SASSIGN) 400656 o->op_flags |= OPf_SPECIAL|OPf_REF; 647620 else if (!type) { /* local() */ 21888 switch (localize) { case 1: 17736 o->op_private |= OPpLVAL_INTRO; 17736 o->op_flags &= ~OPf_SPECIAL; 17736 PL_hints |= HINT_BLOCK_SCOPE; 17736 break; case 0: ###### break; case -1: ###### if (ckWARN(WARN_SYNTAX)) { ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Useless localization of %s", OP_DESC(o)); } } } 625732 else if (type != OP_GREPSTART && type != OP_ENTERSUB && type != OP_LEAVESUBLV) 329440 o->op_flags |= OPf_REF; 1048276 return o; } STATIC bool S_scalar_mod_type(pTHX_ const OP *o, I32 type) 186752 { 186752 switch (type) { case OP_SASSIGN: 12780 if (o->op_type == OP_RV2GV) 12780 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: ###### return TRUE; default: 173972 return FALSE; } } STATIC bool S_is_handle_constructor(pTHX_ const OP *o, I32 numargs) 6242 { 6242 switch (o->op_type) { case OP_PIPE_OP: case OP_SOCKPAIR: ###### if (numargs == 2) ###### 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: 1856 if (numargs == 1) 1856 return TRUE; /* FALL THROUGH */ default: 4386 return FALSE; } } OP * Perl_refkids(pTHX_ OP *o, I32 type) 35094 { 35094 if (o && o->op_flags & OPf_KIDS) { 35094 OP *kid; 70188 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 35094 ref(kid, type); } 35094 return o; } OP * Perl_ref(pTHX_ OP *o, I32 type) 699988 { dVAR; 699988 OP *kid; 699988 if (!o || PL_error_count) ###### return o; 699988 switch (o->op_type) { case OP_ENTERSUB: 4634 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { 4466 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 4466 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 4466 assert(cUNOPo->op_first->op_type == OP_NULL); 4466 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ 4466 o->op_flags |= OPf_SPECIAL; } 4466 break; case OP_COND_EXPR: ###### for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) ###### ref(kid, type); 4650 break; case OP_RV2SV: 4650 if (type == OP_DEFINED) 4217 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 4650 ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_PADSV: 107892 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 76385 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : type == OP_RV2HV ? OPpDEREF_HV : OPpDEREF_SV); 76385 o->op_flags |= OPf_MOD; } 76385 break; case OP_THREADSV: ###### o->op_flags |= OPf_MOD; /* XXX ??? */ ###### break; case OP_RV2AV: case OP_RV2HV: 165181 o->op_flags |= OPf_REF; /* FALL THROUGH */ case OP_RV2GV: 192014 if (type == OP_DEFINED) ###### o->op_flags |= OPf_SPECIAL; /* don't create GV */ 192014 ref(cUNOPo->op_first, o->op_type); 192014 break; case OP_PADAV: case OP_PADHV: 46766 o->op_flags |= OPf_REF; 46766 break; case OP_SCALAR: case OP_NULL: 2675 if (!(o->op_flags & OPf_KIDS)) ###### break; 2675 ref(cBINOPo->op_first, type); 2675 break; case OP_AELEM: case OP_HELEM: 15843 ref(cBINOPo->op_first, o->op_type); 15843 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 11097 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : type == OP_RV2HV ? OPpDEREF_HV : OPpDEREF_SV); 11097 o->op_flags |= OPf_MOD; } 11097 break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: case OP_LIST: 21800 if (!(o->op_flags & OPf_KIDS)) ###### break; 21800 ref(cLISTOPo->op_last, type); break; default: 699988 break; } 699988 return scalar(o); } STATIC OP * S_dup_attrlist(pTHX_ OP *o) ###### { ###### 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. */ ###### if (o->op_type == OP_CONST) ###### rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv)); else { ###### assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); ###### for (o = cLISTOPo->op_first; o; o=o->op_sibling) { ###### if (o->op_type == OP_CONST) ###### rop = append_elem(OP_LIST, rop, newSVOP(OP_CONST, o->op_flags, ###### SvREFCNT_inc(cSVOPo->op_sv))); } } ###### return rop; } STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) ###### { dVAR; ###### SV *stashsv; /* fake up C */ ###### ENTER; /* need to protect against side-effects of 'use' */ ###### SAVEINT(PL_expect); ###### stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; #define ATTRSMODULE "attributes" #define ATTRSMODULE_PM "attributes.pm" ###### if (for_my) { /* Don't force the C if we don't need it. */ ###### SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, ###### sizeof(ATTRSMODULE_PM)-1, 0); ###### if (svp && *svp != &PL_sv_undef) ; /* already in %INC */ else ###### Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), Nullsv); } else { ###### 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)))); } ###### LEAVE; } STATIC void S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) ###### { ###### OP *pack, *imop, *arg; ###### SV *meth, *stashsv; ###### if (!attrs) ###### return; assert(target->op_type == OP_PADSV || target->op_type == OP_PADHV || ###### target->op_type == OP_PADAV); /* Ensure that attributes.pm is loaded. */ ###### apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE); /* Need package name for method call. */ ###### pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); /* Build up the real arg-list. */ ###### stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; ###### arg = newOP(OP_PADSV, 0); ###### arg->op_targ = target->op_targ; ###### 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 */ ###### meth = newSVpvn_share("import", 6, 0); ###### 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))); ###### imop->op_private |= OPpENTERSUB_NOMOD; /* Combine the ops. */ ###### *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) 270223 { 270223 I32 type; 270223 if (!o || PL_error_count) ###### return o; 270223 type = o->op_type; 270223 if (type == OP_LIST) { 27829 OP *kid; 136613 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 108784 my_kid(kid, attrs, imopsp); 242394 } else if (type == OP_UNDEF) { ###### return o; 242394 } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ 22158 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ ###### yyerror(Perl_form(aTHX_ "Can't declare %s in %s", OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); 22158 } else if (attrs) { ###### GV *gv = cGVOPx_gv(cUNOPo->op_first); ###### PL_in_my = FALSE; ###### PL_in_my_stash = Nullhv; ###### 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); } 22158 o->op_private |= OPpOUR_INTRO; 22158 return o; } 220236 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; } 220236 else if (attrs && type != OP_PUSHMARK) { ###### HV *stash; ###### PL_in_my = FALSE; ###### PL_in_my_stash = Nullhv; /* check for C when deciding package */ ###### stash = PAD_COMPNAME_TYPE(o->op_targ); ###### if (!stash) ###### stash = PL_curstash; ###### apply_attrs_my(stash, o, attrs, imopsp); } 248065 o->op_flags |= OPf_MOD; 248065 o->op_private |= OPpLVAL_INTRO; 248065 return o; } OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs) 161439 { 161439 OP *rops = Nullop; 161439 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 161439 maybe_scalar = 1; #endif 161439 if (attrs) ###### SAVEFREEOP(attrs); 161439 o = my_kid(o, attrs, &rops); 161439 if (rops) { ###### if (maybe_scalar && o->op_type == OP_PADSV) { ###### o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o)); ###### o->op_private |= OPpLVAL_INTRO; } else ###### o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); } 161439 PL_in_my = FALSE; 161439 PL_in_my_stash = Nullhv; 161439 return o; } OP * Perl_my(pTHX_ OP *o) 161195 { 161195 return my_attrs(o, Nullop); } OP * Perl_sawparens(pTHX_ OP *o) 144576 { 144576 if (o) 144576 o->op_flags |= OPf_PARENS; 144576 return o; } OP * Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) 54734 { 54734 OP *o; 54734 bool ismatchop = 0; 54734 if (ckWARN(WARN_MISC) && (left->op_type == OP_RV2AV || left->op_type == OP_RV2HV || left->op_type == OP_PADAV || left->op_type == OP_PADHV)) { ###### const char *desc = PL_op_desc[(right->op_type == OP_SUBST || right->op_type == OP_TRANS) ###### ? right->op_type : OP_MATCH]; ###### const char *sample = ((left->op_type == OP_RV2AV || left->op_type == OP_PADAV) ###### ? "@array" : "%hash"); ###### Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %s will act on scalar(%s)", desc, sample, sample); } 54734 if (right->op_type == OP_CONST && cSVOPx(right)->op_private & OPpCONST_BARE && cSVOPx(right)->op_private & OPpCONST_STRICT) { ###### no_bareword_allowed(right); } 54734 ismatchop = right->op_type == OP_MATCH || right->op_type == OP_SUBST || right->op_type == OP_TRANS; 54734 if (ismatchop && right->op_private & OPpTARGET_MY) { ###### right->op_targ = 0; ###### right->op_private &= ~OPpTARGET_MY; } 54734 if (!(right->op_flags & OPf_STACKED) && ismatchop) { 54521 right->op_flags |= OPf_STACKED; 54521 if (right->op_type != OP_MATCH && ! (right->op_type == OP_TRANS && right->op_private & OPpTRANS_IDENTICAL)) 21947 left = mod(left, right->op_type); 54521 if (right->op_type == OP_TRANS) 1294 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); else 53227 o = prepend_elem(right->op_type, scalar(left), right); 54521 if (type == OP_NOT) 3580 return newUNOP(OP_NOT, 0, scalar(o)); 50941 return o; } else 213 return bind_match(type, left, pmruntime(newPMOP(OP_MATCH, 0), right, 0)); } OP * Perl_invert(pTHX_ OP *o) 11678 { 11678 if (!o) ###### return o; /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */ 11678 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); } OP * Perl_scope(pTHX_ OP *o) 163890 { dVAR; 163890 if (o) { 163890 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { 110017 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); 110017 o->op_type = OP_LEAVE; 110017 o->op_ppaddr = PL_ppaddr[OP_LEAVE]; } 53873 else if (o->op_type == OP_LINESEQ) { 53355 OP *kid; 53355 o->op_type = OP_SCOPE; 53355 o->op_ppaddr = PL_ppaddr[OP_SCOPE]; 53355 kid = ((LISTOP*)o)->op_first; 53355 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) 53355 op_null(kid); } else 518 o = newLISTOP(OP_SCOPE, 0, o, Nullop); } 163890 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) 375974 { 375974 const int retval = PL_savestack_ix; 375974 pad_block_start(full); 375974 SAVEHINTS(); 375974 PL_hints &= ~HINT_BLOCK_SCOPE; 375974 SAVESPTR(PL_compiling.cop_warnings); 375974 if (! specialWARN(PL_compiling.cop_warnings)) { ###### PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; ###### SAVEFREESV(PL_compiling.cop_warnings) ; } 375974 SAVESPTR(PL_compiling.cop_io); 375974 if (! specialCopIO(PL_compiling.cop_io)) { ###### PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ; ###### SAVEFREESV(PL_compiling.cop_io) ; } 375974 return retval; } OP* Perl_block_end(pTHX_ I32 floor, OP *seq) 375974 { 375974 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; 375974 OP* retval = scalarseq(seq); 375974 LEAVE_SCOPE(floor); 375974 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 375974 if (needblockscope) 280509 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ 375974 pad_leavemy(); 375974 return retval; } STATIC OP * S_newDEFSVOP(pTHX) 3170 { 3170 const I32 offset = pad_findmy("$_"); 3170 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { 3170 return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); } else { ###### OP *o = newOP(OP_PADSV, 0); ###### o->op_targ = offset; ###### return o; } } void Perl_newPROG(pTHX_ OP *o) 12652 { 12652 if (PL_in_eval) { 12087 if (PL_eval_root) ###### return; 12087 PL_eval_root = newUNOP(OP_LEAVEEVAL, ((PL_in_eval & EVAL_KEEPERR) ? OPf_SPECIAL : 0), o); 12087 PL_eval_start = linklist(PL_eval_root); 12087 PL_eval_root->op_private |= OPpREFCOUNTED; 12087 OpREFCNT_set(PL_eval_root, 1); 12087 PL_eval_root->op_next = 0; 12087 CALL_PEEP(PL_eval_start); } else { 565 if (o->op_type == OP_STUB) { ###### PL_comppad_name = 0; ###### PL_compcv = 0; ###### FreeOp(o); ###### return; } 565 PL_main_root = scope(sawparens(scalarvoid(o))); 565 PL_curcop = &PL_compiling; 565 PL_main_start = LINKLIST(PL_main_root); 565 PL_main_root->op_private |= OPpREFCOUNTED; 565 OpREFCNT_set(PL_main_root, 1); 565 PL_main_root->op_next = 0; 565 CALL_PEEP(PL_main_start); 565 PL_compcv = 0; /* Register with debugger */ 565 if (PERLDB_INTER) { ###### CV *cv = get_cv("DB::postponed", FALSE); ###### 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) 165209 { 165209 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 { 119493 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') { 447 char *s = PL_bufptr; 447 bool sigil = FALSE; /* some heuristics to detect a potential error */ 894 while (*s && (strchr(", \t\n", *s))) 447 s++; 864 while (1) { 864 if (*s && strchr("@$%*", *s) && *++s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) { 417 s++; 417 sigil = TRUE; 1616 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) 1199 s++; 469 while (*s && (strchr(", \t\n", *s))) 52 s++; } else 447 break; } 447 if (sigil && (*s == ';' || *s == '=')) { ###### Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), "Parentheses missing around \"%s\" list", lex ? (PL_in_my == KEY_our ? "our" : "my") : "local"); } } } 165209 if (lex) 151133 o = my(o); else 14076 o = mod(o, OP_NULL); /* a bit kludgey */ 165209 PL_in_my = FALSE; 165209 PL_in_my_stash = Nullhv; 165209 return o; } OP * Perl_jmaybe(pTHX_ OP *o) 108383 { 108383 if (o->op_type == OP_LIST) { 110 OP *o2; 110 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); } 108383 return o; } OP * Perl_fold_constants(pTHX_ register OP *o) 2655019 { dVAR; 2655019 register OP *curop; 2655019 I32 type = o->op_type; 2655019 SV *sv; 2655019 if (PL_opargs[type] & OA_RETSCALAR) 1426746 scalar(o); 2655019 if (PL_opargs[type] & OA_TARGET && !o->op_targ) 945173 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? */ 2655019 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))) { ###### o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)]; } 2655019 if (!(PL_opargs[type] & OA_FOLDCONST)) 2126556 goto nope; 528463 switch (type) { case OP_NEGATE: /* XXX might want a ck_negate() for this */ 5975 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; 5975 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? */ 6328 if (PL_hints & HINT_LOCALE) ###### goto nope; } 528463 if (PL_error_count) ###### goto nope; /* Don't try to run w/ errors */ 1009098 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 940266 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) { 459631 goto nope; } } 68832 curop = LINKLIST(o); 68832 o->op_next = 0; 68832 PL_op = curop; 68832 CALLRUNOPS(aTHX); 68832 sv = *(PL_stack_sp--); 68832 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ 68827 pad_swipe(o->op_targ, FALSE); 5 else if (SvTEMP(sv)) { /* grab mortal temp? */ 3 (void)SvREFCNT_inc(sv); 3 SvTEMP_off(sv); } 68832 op_free(o); 68832 if (type == OP_RV2GV) ###### return newGVOP(OP_GV, 0, (GV*)sv); 68832 return newSVOP(OP_CONST, 0, sv); nope: 2586187 return o; } OP * Perl_gen_constant_list(pTHX_ register OP *o) 178 { dVAR; 178 register OP *curop; 178 const I32 oldtmps_floor = PL_tmps_floor; 178 list(o); 178 if (PL_error_count) ###### return o; /* Don't attempt to run with errors */ 178 PL_op = curop = LINKLIST(o); 178 o->op_next = 0; 178 CALL_PEEP(curop); 178 pp_pushmark(); 178 CALLRUNOPS(aTHX); 178 PL_op = curop; 178 pp_anonlist(); 178 PL_tmps_floor = oldtmps_floor; 178 o->op_type = OP_RV2AV; 178 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 178 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ 178 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ 178 o->op_opt = 0; /* needs to be revisited in peep() */ 178 curop = ((UNOP*)o)->op_first; 178 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--)); 178 op_free(curop); 178 linklist(o); 178 return list(o); } OP * Perl_convert(pTHX_ I32 type, I32 flags, OP *o) 385869 { dVAR; 385869 if (!o || o->op_type != OP_LIST) 236677 o = newLISTOP(OP_LIST, 0, o, Nullop); else 149192 o->op_flags &= ~OPf_WANT; 385869 if (!(PL_opargs[type] & OA_MARK)) 186095 op_null(cLISTOPo->op_first); 385869 o->op_type = (OPCODE)type; 385869 o->op_ppaddr = PL_ppaddr[type]; 385869 o->op_flags |= flags; 385869 o = CHECKOP(type, o); 385869 if (o->op_type != (unsigned)type) 10850 return o; 375019 return fold_constants(o); } /* List constructors */ OP * Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) 788964 { 788964 if (!first) 42964 return last; 746000 if (!last) 14368 return first; 731632 if (first->op_type != (unsigned)type || (type == OP_LIST && (first->op_flags & OPf_PARENS))) { 290619 return newLISTOP(type, 0, first, last); } 441013 if (first->op_flags & OPf_KIDS) 441013 ((LISTOP*)first)->op_last->op_sibling = last; else { ###### first->op_flags |= OPf_KIDS; ###### ((LISTOP*)first)->op_first = last; } 441013 ((LISTOP*)first)->op_last = last; 441013 return first; } OP * Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) 1008265 { 1008265 if (!first) 270409 return (OP*)last; 737856 if (!last) 221656 return (OP*)first; 516200 if (first->op_type != (unsigned)type) 4442 return prepend_elem(type, (OP*)first, (OP*)last); 511758 if (last->op_type != (unsigned)type) 22236 return append_elem(type, (OP*)first, (OP*)last); 489522 first->op_last->op_sibling = last->op_first; 489522 first->op_last = last->op_last; 489522 first->op_flags |= (last->op_flags & OPf_KIDS); 489522 FreeOp(last); 489522 return (OP*)first; } OP * Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) 1088130 { 1088130 if (!first) ###### return last; 1088130 if (!last) 39382 return first; 1048748 if (last->op_type == (unsigned)type) { 211052 if (type == OP_LIST) { /* already a PUSHMARK there */ 15104 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; 15104 ((LISTOP*)last)->op_first->op_sibling = first; 15104 if (!(first->op_flags & OPf_PARENS)) 15103 last->op_flags &= ~OPf_PARENS; } else { 195948 if (!(last->op_flags & OPf_KIDS)) { 57849 ((LISTOP*)last)->op_last = first; 57849 last->op_flags |= OPf_KIDS; } 195948 first->op_sibling = ((LISTOP*)last)->op_first; 195948 ((LISTOP*)last)->op_first = first; } 211052 last->op_flags |= OPf_KIDS; 211052 return last; } 837696 return newLISTOP(type, 0, first, last); } /* Constructors */ OP * Perl_newNULLLIST(pTHX) 6635 { 6635 return newOP(OP_STUB, 0); } OP * Perl_force_list(pTHX_ OP *o) 353996 { 353996 if (!o || o->op_type != OP_LIST) 229142 o = newLISTOP(OP_LIST, 0, o, Nullop); 353996 op_null(o); 353996 return o; } OP * Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 1598775 { dVAR; 1598775 LISTOP *listop; 1598775 NewOp(1101, listop, 1, LISTOP); 1598775 listop->op_type = (OPCODE)type; 1598775 listop->op_ppaddr = PL_ppaddr[type]; 1598775 if (first || last) 1590537 flags |= OPf_KIDS; 1598775 listop->op_flags = (U8)flags; 1598775 if (!last && first) 458099 last = first; 1140676 else if (!first && last) ###### first = last; 1140676 else if (first) 1132438 first->op_sibling = last; 1598775 listop->op_first = first; 1598775 listop->op_last = last; 1598775 if (type == OP_LIST) { 786571 OP* pushop; 786571 pushop = newOP(OP_PUSHMARK, 0); 786571 pushop->op_sibling = first; 786571 listop->op_first = pushop; 786571 listop->op_flags |= OPf_KIDS; 786571 if (!last) 8238 listop->op_last = pushop; } 1598775 return CHECKOP(type, listop); } OP * Perl_newOP(pTHX_ I32 type, I32 flags) 1943232 { dVAR; 1943232 OP *o; 1943232 NewOp(1101, o, 1, OP); 1943232 o->op_type = (OPCODE)type; 1943232 o->op_ppaddr = PL_ppaddr[type]; 1943232 o->op_flags = (U8)flags; 1943232 o->op_next = o; 1943232 o->op_private = (U8)(0 | (flags >> 8)); 1943232 if (PL_opargs[type] & OA_RETSCALAR) 866736 scalar(o); 1943232 if (PL_opargs[type] & OA_TARGET) 3237 o->op_targ = pad_alloc(type, SVs_PADTMP); 1943232 return CHECKOP(type, o); } OP * Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) 1535278 { dVAR; 1535278 UNOP *unop; 1535278 if (!first) ###### first = newOP(OP_STUB, 0); 1535278 if (PL_opargs[type] & OA_MARK) 158462 first = force_list(first); 1535278 NewOp(1101, unop, 1, UNOP); 1535278 unop->op_type = (OPCODE)type; 1535278 unop->op_ppaddr = PL_ppaddr[type]; 1535278 unop->op_first = first; 1535278 unop->op_flags = flags | OPf_KIDS; 1535278 unop->op_private = (U8)(1 | (flags >> 8)); 1535278 unop = (UNOP*) CHECKOP(type, unop); 1535278 if (unop->op_next) 34237 return (OP*)unop; 1501041 return fold_constants((OP *) unop); } OP * Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 787574 { dVAR; 787574 BINOP *binop; 787574 NewOp(1101, binop, 1, BINOP); 787574 if (!first) ###### first = newOP(OP_NULL, 0); 787574 binop->op_type = (OPCODE)type; 787574 binop->op_ppaddr = PL_ppaddr[type]; 787574 binop->op_first = first; 787574 binop->op_flags = flags | OPf_KIDS; 787574 if (!last) { ###### last = first; ###### binop->op_private = (U8)(1 | (flags >> 8)); } else { 787574 binop->op_private = (U8)(2 | (flags >> 8)); 787574 first->op_sibling = last; } 787574 binop = (BINOP*)CHECKOP(type, binop); 787574 if (binop->op_next || binop->op_type != (OPCODE)type) 8615 return (OP*)binop; 778959 binop->op_last = binop->op_first->op_sibling; 778959 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) ###### { ###### if (*((const UV *)a) < (*(const UV *)b)) ###### 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) 1317 { 1317 SV *tstr = ((SVOP*)expr)->op_sv; 1317 SV *rstr = ((SVOP*)repl)->op_sv; 1317 STRLEN tlen; 1317 STRLEN rlen; 1317 const U8 *t = (U8*)SvPV_const(tstr, tlen); 1317 const U8 *r = (U8*)SvPV_const(rstr, rlen); 1317 register I32 i; 1317 register I32 j; 1317 I32 del; 1317 I32 complement; 1317 I32 squash; 1317 I32 grows = 0; 1317 register short *tbl; 1317 PL_hints |= HINT_BLOCK_SCOPE; 1317 complement = o->op_private & OPpTRANS_COMPLEMENT; 1317 del = o->op_private & OPpTRANS_DELETE; 1317 squash = o->op_private & OPpTRANS_SQUASH; 1317 if (SvUTF8(tstr)) ###### o->op_private |= OPpTRANS_FROM_UTF; 1317 if (SvUTF8(rstr)) ###### o->op_private |= OPpTRANS_TO_UTF; 1317 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { ###### SV* listsv = newSVpvn("# comment\n",10); ###### SV* transv = 0; ###### const U8* tend = t + tlen; ###### const U8* rend = r + rlen; ###### STRLEN ulen; ###### UV tfirst = 1; ###### UV tlast = 0; ###### IV tdiff; ###### UV rfirst = 1; ###### UV rlast = 0; ###### IV rdiff; ###### IV diff; ###### I32 none = 0; ###### U32 max = 0; ###### I32 bits; ###### I32 havefinal = 0; ###### U32 final = 0; ###### I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; ###### I32 to_utf = o->op_private & OPpTRANS_TO_UTF; ###### U8* tsave = NULL; ###### U8* rsave = NULL; ###### if (!from_utf) { ###### STRLEN len = tlen; ###### t = tsave = bytes_to_utf8(t, &len); ###### tend = t + len; } ###### 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. */ ###### if (complement) { ###### U8 tmpbuf[UTF8_MAXBYTES+1]; ###### UV *cp; ###### UV nextmin = 0; ###### New(1109, cp, 2*tlen, UV); ###### i = 0; ###### transv = newSVpvn("",0); ###### while (t < tend) { ###### cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0); ###### t += ulen; ###### if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { ###### t++; ###### cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0); ###### t += ulen; } else { ###### cp[2*i+1] = cp[2*i]; } ###### i++; } ###### qsort(cp, i, 2*sizeof(UV), uvcompare); ###### for (j = 0; j < i; j++) { ###### UV val = cp[2*j]; ###### diff = val - nextmin; ###### if (diff > 0) { ###### t = uvuni_to_utf8(tmpbuf,nextmin); ###### sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); ###### if (diff > 1) { ###### U8 range_mark = UTF_TO_NATIVE(0xff); ###### t = uvuni_to_utf8(tmpbuf, val - 1); ###### sv_catpvn(transv, (char *)&range_mark, 1); ###### sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); } } ###### val = cp[2*j+1]; ###### if (val >= nextmin) ###### nextmin = val + 1; } ###### t = uvuni_to_utf8(tmpbuf,nextmin); ###### sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); { ###### U8 range_mark = UTF_TO_NATIVE(0xff); ###### sv_catpvn(transv, (char *)&range_mark, 1); } ###### t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff, UNICODE_ALLOW_SUPER); ###### sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); ###### t = (const U8*)SvPVX_const(transv); ###### tlen = SvCUR(transv); ###### tend = t + tlen; ###### Safefree(cp); } ###### else if (!rlen && !del) { ###### r = t; rlen = tlen; rend = tend; } ###### if (!squash) { ###### if ((!rlen && !del) || t == r || (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) { ###### o->op_private |= OPpTRANS_IDENTICAL; } } ###### while (t < tend || tfirst <= tlast) { /* see if we need more "t" chars */ ###### if (tfirst > tlast) { ###### tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); ###### t += ulen; ###### if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ ###### t++; ###### tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); ###### t += ulen; } else ###### tlast = tfirst; } /* now see if we need more "r" chars */ ###### if (rfirst > rlast) { ###### if (r < rend) { ###### rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); ###### r += ulen; ###### if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ ###### r++; ###### rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); ###### r += ulen; } else ###### rlast = rfirst; } else { ###### if (!havefinal++) ###### final = rlast; ###### rfirst = rlast = 0xffffffff; } } /* now see which range will peter our first, if either. */ ###### tdiff = tlast - tfirst; ###### rdiff = rlast - rfirst; ###### if (tdiff <= rdiff) ###### diff = tdiff; else ###### diff = rdiff; ###### if (rfirst == 0xffffffff) { ###### diff = tdiff; /* oops, pretend rdiff is infinite */ ###### if (diff > 0) ###### Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n", (long)tfirst, (long)tlast); else ###### Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst); } else { ###### if (diff > 0) ###### Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n", (long)tfirst, (long)(tfirst + diff), (long)rfirst); else ###### Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n", (long)tfirst, (long)rfirst); ###### if (rfirst + diff > max) ###### max = rfirst + diff; ###### if (!grows) ###### grows = (tfirst < rfirst && UNISKIP(tfirst) < UNISKIP(rfirst + diff)); ###### rfirst += diff + 1; } ###### tfirst += diff + 1; } ###### none = ++max; ###### if (del) ###### del = ++max; ###### if (max > 0xffff) ###### bits = 32; ###### else if (max > 0xff) ###### bits = 16; else ###### bits = 8; ###### Safefree(cPVOPo->op_pv); ###### cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none); ###### SvREFCNT_dec(listsv); ###### if (transv) ###### SvREFCNT_dec(transv); ###### if (!del && havefinal && rlen) ###### (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, newSVuv((UV)final), 0); ###### if (grows) ###### o->op_private |= OPpTRANS_GROWS; ###### if (tsave) ###### Safefree(tsave); ###### if (rsave) ###### Safefree(rsave); ###### op_free(expr); ###### op_free(repl); ###### return o; } 1317 tbl = (short*)cPVOPo->op_pv; 1317 if (complement) { 1 Zero(tbl, 256, short); 64 for (i = 0; i < (I32)tlen; i++) 63 tbl[t[i]] = -1; 257 for (i = 0, j = 0; i < 256; i++) { 256 if (!tbl[i]) { 193 if (j >= (I32)rlen) { 193 if (del) 193 tbl[i] = -2; ###### else if (rlen) ###### tbl[i] = r[j-1]; else ###### tbl[i] = (short)i; } else { ###### if (i < 128 && r[j] >= 128) ###### grows = 1; ###### tbl[i] = r[j++]; } } } 1 if (!del) { ###### if (!rlen) { ###### j = rlen; ###### if (!squash) ###### o->op_private |= OPpTRANS_IDENTICAL; } ###### else if (j >= (I32)rlen) ###### j = rlen - 1; else ###### cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short); ###### tbl[0x100] = rlen - j; ###### for (i=0; i < (I32)rlen - j; i++) ###### tbl[0x101+i] = r[j+i]; } } else { 1316 if (!rlen && !del) { 519 r = t; rlen = tlen; 519 if (!squash) 519 o->op_private |= OPpTRANS_IDENTICAL; } 797 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) { 3 o->op_private |= OPpTRANS_IDENTICAL; } 338212 for (i = 0; i < 256; i++) 336896 tbl[i] = -1; 37215 for (i = 0, j = 0; i < (I32)tlen; i++,j++) { 35899 if (j >= (I32)rlen) { 4295 if (del) { 11 if (tbl[t[i]] == -1) 9 tbl[t[i]] = -2; 9 continue; } 4284 --j; } 35888 if (tbl[t[i]] == -1) { 35888 if (t[i] < 128 && r[j] >= 128) ###### grows = 1; 35888 tbl[t[i]] = r[j]; } } } 1317 if (grows) ###### o->op_private |= OPpTRANS_GROWS; 1317 op_free(expr); 1317 op_free(repl); 1317 return o; } OP * Perl_newPMOP(pTHX_ I32 type, I32 flags) 70148 { dVAR; 70148 PMOP *pmop; 70148 NewOp(1101, pmop, 1, PMOP); 70148 pmop->op_type = (OPCODE)type; 70148 pmop->op_ppaddr = PL_ppaddr[type]; 70148 pmop->op_flags = (U8)flags; 70148 pmop->op_private = (U8)(0 | (flags >> 8)); 70148 if (PL_hints & HINT_RE_TAINT) 14618 pmop->op_pmpermflags |= PMf_RETAINT; 70148 if (PL_hints & HINT_LOCALE) ###### pmop->op_pmpermflags |= PMf_LOCALE; 70148 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 */ 70148 if (type != OP_TRANS && PL_curstash) { 70148 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab); 70148 if (!mg) { 6167 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0); } 70148 pmop->op_pmnext = (PMOP*)mg->mg_obj; 70148 mg->mg_obj = (SV*)pmop; 70148 PmopSTASH_set(pmop,PL_curstash); } 70148 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) 71465 { dVAR; 71465 PMOP *pm; 71465 LOGOP *rcop; 71465 I32 repl_has_vars = 0; 71465 OP* repl = Nullop; 71465 bool reglist; 71465 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) { /* last element in list is the replacement; pop it */ 25385 OP* kid; 25385 repl = cLISTOPx(expr)->op_last; 25385 kid = cLISTOPx(expr)->op_first; 53096 while (kid->op_sibling != repl) 27711 kid = kid->op_sibling; 25385 kid->op_sibling = Nullop; 25385 cLISTOPx(expr)->op_last = kid; } 71465 if (isreg && expr->op_type == OP_LIST && cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last) { /* convert single element list to element */ 24125 OP* oe = expr; 24125 expr = cLISTOPx(oe)->op_first->op_sibling; 24125 cLISTOPx(oe)->op_first->op_sibling = Nullop; 24125 cLISTOPx(oe)->op_last = Nullop; 24125 op_free(oe); } 71465 if (o->op_type == OP_TRANS) { 1317 return pmtrans(o, expr, repl); } 70148 reglist = isreg && expr->op_type == OP_LIST; 70148 if (reglist) 4184 op_null(expr); 70148 PL_hints |= HINT_BLOCK_SCOPE; 70148 pm = (PMOP*)o; 70148 if (expr->op_type == OP_CONST) { 63931 STRLEN plen; 63931 SV *pat = ((SVOP*)expr)->op_sv; 63931 const char *p = SvPV_const(pat, plen); 63931 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { 562 U32 was_readonly = SvREADONLY(pat); 562 if (was_readonly) { 562 if (SvFAKE(pat)) { ###### sv_force_normal_flags(pat, 0); ###### assert(!SvREADONLY(pat)); ###### was_readonly = 0; } else { 562 SvREADONLY_off(pat); } } 562 sv_setpvn(pat, "\\s+", 3); 562 SvFLAGS(pat) |= was_readonly; 562 p = SvPV_const(pat, plen); 562 pm->op_pmflags |= PMf_SKIPWHITE; } 63931 if (DO_UTF8(pat)) ###### pm->op_pmdynflags |= PMdf_UTF8; /* FIXME - can we make this function take const char * args? */ 63931 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm)); 63931 if (strEQ("\\s+", PM_GETRE(pm)->precomp)) 1127 pm->op_pmflags |= PMf_WHITE; 63931 op_free(expr); } else { 6217 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) 6170 expr = newUNOP((!(PL_hints & HINT_RE_EVAL) ? OP_REGCRESET : OP_REGCMAYBE),0,expr); 6217 NewOp(1101, rcop, 1, LOGOP); 6217 rcop->op_type = OP_REGCOMP; 6217 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; 6217 rcop->op_first = scalar(expr); 6217 rcop->op_flags |= OPf_KIDS | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) | (reglist ? OPf_STACKED : 0); 6217 rcop->op_private = 1; 6217 rcop->op_other = o; 6217 if (reglist) 4184 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP); /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ 6217 PL_cv_has_eval = 1; /* establish postfix order */ 6217 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) { 6170 LINKLIST(expr); 6170 rcop->op_next = expr; 6170 ((UNOP*)expr)->op_first->op_next = (OP*)rcop; } else { 47 rcop->op_next = LINKLIST(expr); 47 expr->op_next = (OP*)rcop; } 6217 prepend_elem(o->op_type, scalar((OP*)rcop), o); } 70148 if (repl) { 24068 OP *curop; 24068 if (pm->op_pmflags & PMf_EVAL) { 785 curop = 0; 785 if (CopLINE(PL_curcop) < (line_t)PL_multi_end) ###### CopLINE_set(PL_curcop, (line_t)PL_multi_end); } 23283 else if (repl->op_type == OP_CONST) 17601 curop = repl; else { 5682 OP *lastop = 0; 8357 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { 7801 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 6159 if (curop->op_type == OP_GV) { 5368 GV *gv = cGVOPx_gv(curop); 5368 repl_has_vars = 1; 5368 if (strchr("&`'123456789+-\016\022", *GvENAME(gv))) 4896 break; } 791 else if (curop->op_type == OP_RV2CV) ###### break; 791 else if (curop->op_type == OP_RV2SV || curop->op_type == OP_RV2AV || curop->op_type == OP_RV2HV || curop->op_type == OP_RV2GV) { 559 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/ 230 break; } 232 else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || curop->op_type == OP_PADANY) { 232 repl_has_vars = 1; } ###### else if (curop->op_type == OP_PUSHRE) ; /* Okay here, dangerous in newASSIGNOP */ else 2675 break; } 2675 lastop = curop; } } 24068 if (curop == repl && !(repl_has_vars && (!PM_GETRE(pm) || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) { 18110 pm->op_pmflags |= PMf_CONST; /* const for long enough */ 18110 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ 18110 prepend_elem(o->op_type, scalar(repl), o); } else { 5958 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */ 47 pm->op_pmflags |= PMf_MAYBE_CONST; 47 pm->op_pmpermflags |= PMf_MAYBE_CONST; } 5958 NewOp(1101, rcop, 1, LOGOP); 5958 rcop->op_type = OP_SUBSTCONT; 5958 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT]; 5958 rcop->op_first = scalar(repl); 5958 rcop->op_flags |= OPf_KIDS; 5958 rcop->op_private = 1; 5958 rcop->op_other = o; /* establish postfix order */ 5958 rcop->op_next = LINKLIST(repl); 5958 repl->op_next = (OP*)rcop; 5958 pm->op_pmreplroot = scalar((OP*)rcop); 5958 pm->op_pmreplstart = LINKLIST(rcop); 5958 rcop->op_next = 0; } } 70148 return (OP*)pm; } OP * Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) 1810678 { dVAR; 1810678 SVOP *svop; 1810678 NewOp(1101, svop, 1, SVOP); 1810678 svop->op_type = (OPCODE)type; 1810678 svop->op_ppaddr = PL_ppaddr[type]; 1810678 svop->op_sv = sv; 1810678 svop->op_next = (OP*)svop; 1810678 svop->op_flags = (U8)flags; 1810678 if (PL_opargs[type] & OA_RETSCALAR) 1757492 scalar((OP*)svop); 1810678 if (PL_opargs[type] & OA_TARGET) 1055 svop->op_targ = pad_alloc(type, SVs_PADTMP); 1810678 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) 52035 { dVAR; #ifdef USE_ITHREADS if (gv) GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc(gv)); #else 52035 return newSVOP(type, flags, SvREFCNT_inc(gv)); #endif } OP * Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) 8706 { dVAR; 8706 PVOP *pvop; 8706 NewOp(1101, pvop, 1, PVOP); 8706 pvop->op_type = (OPCODE)type; 8706 pvop->op_ppaddr = PL_ppaddr[type]; 8706 pvop->op_pv = pv; 8706 pvop->op_next = (OP*)pvop; 8706 pvop->op_flags = (U8)flags; 8706 if (PL_opargs[type] & OA_RETSCALAR) 8706 scalar((OP*)pvop); 8706 if (PL_opargs[type] & OA_TARGET) ###### pvop->op_targ = pad_alloc(type, SVs_PADTMP); 8706 return CHECKOP(type, pvop); } void Perl_package(pTHX_ OP *o) 10455 { 10455 const char *name; 10455 STRLEN len; 10455 save_hptr(&PL_curstash); 10455 save_item(PL_curstname); 10455 name = SvPV_const(cSVOPo->op_sv, len); 10455 PL_curstash = gv_stashpvn(name, len, TRUE); 10455 sv_setpvn(PL_curstname, name, len); 10455 op_free(o); 10455 PL_hints |= HINT_BLOCK_SCOPE; 10455 PL_copline = NOLINE; 10455 PL_expect = XSTATE; } void Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) 22597 { 22597 OP *pack; 22597 OP *imop; 22597 OP *veop; 22597 if (idop->op_type != OP_CONST) ###### Perl_croak(aTHX_ "Module name must be constant"); 22597 veop = Nullop; 22597 if (version != Nullop) { 6 SV *vesv = ((SVOP*)version)->op_sv; 6 if (arg == Nullop && !SvNIOKp(vesv)) { ###### arg = version; } else { 6 OP *pack; 6 SV *meth; 6 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 */ 6 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to VERSION */ 6 meth = newSVpvn_share("VERSION", 7, 0); 6 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 */ 22597 if (arg && arg->op_type == OP_STUB) 1065 imop = arg; /* no import on explicit () */ 21532 else if (SvNIOKp(((SVOP*)idop)->op_sv)) { 2837 imop = Nullop; /* use 5.0; */ } else { 18695 SV *meth; /* Make copy of idop so we don't free it twice */ 18695 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to import/unimport */ 18695 meth = aver ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0); 18695 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. */ 22597 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. */ 22597 PL_hints |= HINT_BLOCK_SCOPE; 22597 PL_copline = NOLINE; 22597 PL_expect = XSTATE; 22597 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, ...) ###### { ###### va_list args; ###### va_start(args, ver); ###### 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) ###### { ###### OP *modname, *veop, *imop; ###### modname = newSVOP(OP_CONST, 0, name); ###### modname->op_private |= OPpCONST_BARE; ###### if (ver) { ###### veop = newSVOP(OP_CONST, 0, ver); } else ###### veop = Nullop; ###### if (flags & PERL_LOADMOD_NOIMPORT) { ###### imop = sawparens(newNULLLIST()); } ###### else if (flags & PERL_LOADMOD_IMPORT_OPS) { ###### imop = va_arg(*args, OP*); } else { ###### SV *sv; ###### imop = Nullop; ###### sv = va_arg(*args, SV*); ###### while (sv) { ###### imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); ###### sv = va_arg(*args, SV*); } } { ###### const line_t ocopline = PL_copline; ###### COP * const ocurcop = PL_curcop; ###### const int oexpect = PL_expect; ###### utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); ###### PL_expect = oexpect; ###### PL_copline = ocopline; ###### PL_curcop = ocurcop; } } OP * Perl_dofile(pTHX_ OP *term) 326 { 326 OP *doop; 326 GV *gv; 326 gv = gv_fetchpv("do", FALSE, SVt_PVCV); 326 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) 326 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV); 326 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 { 326 doop = newUNOP(OP_DOFILE, 0, scalar(term)); } 326 return doop; } OP * Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) 6379 { 6379 return newBINOP(OP_LSLICE, flags, list(force_list(subscript)), list(force_list(listval)) ); } STATIC I32 S_is_list_assignment(pTHX_ register const OP *o) 293742 { 293742 if (!o) ###### return TRUE; 293742 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS) 86 o = cUNOPo->op_first; 293742 if (o->op_type == OP_COND_EXPR) { 86 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); 86 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); 86 if (t && f) ###### return TRUE; 86 if (t || f) ###### yyerror("Assignment to both a list and a scalar"); 86 return FALSE; } 293656 if (o->op_type == OP_LIST && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR && o->op_private & OPpLVAL_INTRO) ###### return FALSE; 293656 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) 61961 return TRUE; 231695 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) 20360 return TRUE; 211335 if (o->op_type == OP_RV2SV) 39998 return FALSE; 171337 return FALSE; } OP * Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) 325519 { 325519 OP *o; 325519 if (optype) { 31949 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { 9327 return newLOGOP(optype, 0, mod(scalar(left), optype), newUNOP(OP_SASSIGN, 0, scalar(right))); } else { 22622 return newBINOP(optype, OPf_STACKED, mod(scalar(left), optype), scalar(right)); } } 293570 if (is_list_assignment(left)) { 82321 OP *curop; 82321 PL_modcount = 0; /* Grandfathering $[ assignment here. Bletch.*/ /* Only simple assignments like C<< ($[) = 1 >> are allowed */ 82321 PL_eval_start = (left->op_type == OP_CONST) ? right : 0; 82321 left = mod(left, OP_AASSIGN); 82321 if (PL_eval_start) ###### PL_eval_start = 0; 82321 else if (left->op_type == OP_CONST) { /* Result of assignment is always 1 (or we'd be dead already) */ ###### return newSVOP(OP_CONST, 0, newSViv(1)); } /* optimise C to C, and likewise for hashes */ 82321 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV) && right->op_type == OP_STUB && (left->op_private & OPpLVAL_INTRO)) { 1088 op_free(right); 1088 left->op_flags &= ~(OPf_REF|OPf_SPECIAL); 1088 return left; } 81233 curop = list(force_list(left)); 81233 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); 81233 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(). */ 81233 if (!(left->op_private & OPpLVAL_INTRO)) { 36082 OP *lastop = o; 36082 PL_generation++; 427695 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 406741 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 85897 if (curop->op_type == OP_GV) { 22038 GV *gv = cGVOPx_gv(curop); 22038 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) 20674 break; 20674 SvCUR_set(gv, PL_generation); } 63859 else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || curop->op_type == OP_PADANY) { 32060 if (PAD_COMPNAME_GEN(curop->op_targ) == (STRLEN)PL_generation) 1158 break; 30902 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation); } 31799 else if (curop->op_type == OP_RV2CV) ###### break; 31799 else if (curop->op_type == OP_RV2SV || curop->op_type == OP_RV2AV || curop->op_type == OP_RV2HV || curop->op_type == OP_RV2GV) { 22794 if (lastop->op_type != OP_GV) /* funny deref? */ 3898 break; } 9005 else if (curop->op_type == OP_PUSHRE) { 297 if (((PMOP*)curop)->op_pmreplroot) { #ifdef USE_ITHREADS GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET, ((PMOP*)curop)->op_pmreplroot)); #else ###### GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; #endif ###### if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) ###### break; ###### SvCUR_set(gv, PL_generation); } } else 391613 break; } 391613 lastop = curop; } 36082 if (curop != o) 15128 o->op_private |= OPpASSIGN_COMMON; } 81233 if (right && right->op_type == OP_SPLIT) { 2096 OP* tmpop; 2096 if ((tmpop = ((LISTOP*)right)->op_first) && tmpop->op_type == OP_PUSHRE) { 2096 PMOP *pm = (PMOP*)tmpop; 2096 if (left->op_type == OP_RV2AV && !(left->op_private & OPpLVAL_INTRO) && !(o->op_private & OPpASSIGN_COMMON) ) { 3 tmpop = ((UNOP*)left)->op_first; 3 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 3 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv; 3 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */ #endif 3 pm->op_pmflags |= PMf_ONCE; 3 tmpop = cUNOPo->op_first; /* to list (nulled) */ 3 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ 3 tmpop->op_sibling = Nullop; /* don't free split */ 3 right->op_next = tmpop->op_next; /* fix starting loc */ 3 op_free(o); /* blow off assign */ 3 right->op_flags &= ~OPf_WANT; /* "I don't know and I don't care." */ 3 return right; } } else { 2093 if (PL_modcount < RETURN_UNLIMITED_NUMBER && ((LISTOP*)right)->op_last->op_type == OP_CONST) { 186 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; 186 if (SvIVX(sv) == 0) 128 sv_setiv(sv, PL_modcount+1); } } } } 81230 return o; } 211249 if (!right) ###### right = newOP(OP_UNDEF, 0); 211249 if (right->op_type == OP_READLINE) { 2736 right->op_flags |= OPf_STACKED; 2736 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right)); } else { 208513 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ 208513 o = newBINOP(OP_SASSIGN, flags, scalar(right), mod(scalar(left), OP_SASSIGN) ); 208513 if (PL_eval_start) 208513 PL_eval_start = 0; else { ###### o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase)); } } 208513 return o; } OP * Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) 830221 { dVAR; 830221 const U32 seq = intro_my(); 830221 register COP *cop; 830221 NewOp(1101, cop, 1, COP); 830221 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) { ###### cop->op_type = OP_DBSTATE; ###### cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ]; } else { 830221 cop->op_type = OP_NEXTSTATE; 830221 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; } 830221 cop->op_flags = (U8)flags; 830221 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif 830221 PL_compiling.op_private = cop->op_private; 830221 cop->op_next = (OP*)cop; 830221 if (label) { 2794 cop->cop_label = label; 2794 PL_hints |= HINT_BLOCK_SCOPE; } 830221 cop->cop_seq = seq; 830221 cop->cop_arybase = PL_curcop->cop_arybase; 830221 if (specialWARN(PL_curcop->cop_warnings)) 830039 cop->cop_warnings = PL_curcop->cop_warnings ; else 182 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ; 830221 if (specialCopIO(PL_curcop->cop_io)) 830221 cop->cop_io = PL_curcop->cop_io; else ###### cop->cop_io = newSVsv(PL_curcop->cop_io) ; 830221 if (PL_copline == NOLINE) 50271 CopLINE_set(cop, CopLINE(PL_curcop)); else { 779950 CopLINE_set(cop, PL_copline); 779950 PL_copline = NOLINE; } #ifdef USE_ITHREADS CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ #else 830221 CopFILEGV_set(cop, CopFILEGV(PL_curcop)); #endif 830221 CopSTASH_set(cop, PL_curstash); 830221 if (PERLDB_LINE && PL_curstash != PL_debstash) { ###### SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE); ###### if (svp && *svp != &PL_sv_undef ) { ###### (void)SvIOK_on(*svp); ###### SvIV_set(*svp, PTR2IV(cop)); } } 830221 return prepend_elem(OP_LINESEQ, (OP*)cop, o); } OP * Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) 246001 { dVAR; 246001 return new_logop(type, flags, &first, &other); } STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) 274317 { dVAR; 274317 LOGOP *logop; 274317 OP *o; 274317 OP *first = *firstp; 274317 OP *other = *otherp; 274317 if (type == OP_XOR) /* Not short circuit, but here by precedence. */ 8 return newBINOP(type, flags, scalar(first), scalar(other)); 274309 scalarboolean(first); /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ 274309 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) { 11452 if (type == OP_AND || type == OP_OR) { 11452 if (type == OP_AND) 11452 type = OP_OR; else ###### type = OP_AND; 11452 o = first; 11452 first = *firstp = cUNOPo->op_first; 11452 if (o->op_next) 11452 first->op_next = o->op_next; 11452 cUNOPo->op_first = Nullop; 11452 op_free(o); } } 274309 if (first->op_type == OP_CONST) { 1163 if (first->op_private & OPpCONST_STRICT) ###### no_bareword_allowed(first); 1163 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) ###### Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); 1163 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) || ###### (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) || (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) { 1162 op_free(first); 1162 *firstp = Nullop; 1162 if (other->op_type == OP_CONST) ###### other->op_private |= OPpCONST_SHORTCIRCUIT; 1162 return other; } else { /* check for C, or C */ 1 const OP *o2 = other; 1 if ( ! (o2->op_type == OP_LIST && (( o2 = cUNOPx(o2)->op_first)) && o2->op_type == OP_PUSHMARK && (( o2 = o2->op_sibling)) ) ) 1 o2 = other; 1 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV || o2->op_type == OP_PADHV) && o2->op_private & OPpLVAL_INTRO && ckWARN(WARN_DEPRECATED)) { ###### Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Deprecated use of my() in false conditional"); } 1 op_free(other); 1 *otherp = Nullop; 1 if (first->op_type == OP_CONST) 1 first->op_private |= OPpCONST_SHORTCIRCUIT; 1 return first; } } 273146 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) && type != OP_DOR) /* [#24076] Don't warn for err FOO. */ { 68415 const OP *k1 = ((UNOP*)first)->op_first; 68415 const OP *k2 = k1->op_sibling; 68415 OPCODE warnop = 0; 68415 switch (first->op_type) { case OP_NULL: 19507 if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) { ###### warnop = k2->op_type; } ###### break; case OP_SASSIGN: 364 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) { ###### warnop = ((k1->op_type == OP_NULL) ? (OPCODE)k1->op_targ : k1->op_type); } break; } 68415 if (warnop) { ###### const line_t oldline = CopLINE(PL_curcop); ###### CopLINE_set(PL_curcop, PL_copline); ###### 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")); ###### CopLINE_set(PL_curcop, oldline); } } 273146 if (!other) ###### return first; 273146 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) 9327 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ 273146 NewOp(1101, logop, 1, LOGOP); 273146 logop->op_type = (OPCODE)type; 273146 logop->op_ppaddr = PL_ppaddr[type]; 273146 logop->op_first = first; 273146 logop->op_flags = flags | OPf_KIDS; 273146 logop->op_other = LINKLIST(other); 273146 logop->op_private = (U8)(1 | (flags >> 8)); /* establish postfix order */ 273146 logop->op_next = LINKLIST(first); 273146 first->op_next = (OP*)logop; 273146 first->op_sibling = other; 273146 CHECKOP(type,logop); 273146 o = newUNOP(OP_NULL, 0, (OP*)logop); 273146 other->op_next = o; 273146 return o; } OP * Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) 121766 { dVAR; 121766 LOGOP *logop; 121766 OP *start; 121766 OP *o; 121766 if (!falseop) 53039 return newLOGOP(OP_AND, 0, first, trueop); 68727 if (!trueop) ###### return newLOGOP(OP_OR, 0, first, falseop); 68727 scalarboolean(first); 68727 if (first->op_type == OP_CONST) { 1 if (first->op_private & OPpCONST_BARE && first->op_private & OPpCONST_STRICT) { ###### no_bareword_allowed(first); } 1 if (SvTRUE(((SVOP*)first)->op_sv)) { 1 op_free(first); 1 op_free(falseop); 1 return trueop; } else { ###### op_free(first); ###### op_free(trueop); ###### return falseop; } } 68726 NewOp(1101, logop, 1, LOGOP); 68726 logop->op_type = OP_COND_EXPR; 68726 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; 68726 logop->op_first = first; 68726 logop->op_flags = flags | OPf_KIDS; 68726 logop->op_private = (U8)(1 | (flags >> 8)); 68726 logop->op_other = LINKLIST(trueop); 68726 logop->op_next = LINKLIST(falseop); CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ 68726 logop); /* establish postfix order */ 68726 start = LINKLIST(first); 68726 first->op_next = (OP*)logop; 68726 first->op_sibling = trueop; 68726 trueop->op_sibling = falseop; 68726 o = newUNOP(OP_NULL, 0, (OP*)logop); 68726 trueop->op_next = falseop->op_next = o; 68726 o->op_next = start; 68726 return o; } OP * Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) 1502 { dVAR; 1502 LOGOP *range; 1502 OP *flip; 1502 OP *flop; 1502 OP *leftstart; 1502 OP *o; 1502 NewOp(1101, range, 1, LOGOP); 1502 range->op_type = OP_RANGE; 1502 range->op_ppaddr = PL_ppaddr[OP_RANGE]; 1502 range->op_first = left; 1502 range->op_flags = OPf_KIDS; 1502 leftstart = LINKLIST(left); 1502 range->op_other = LINKLIST(right); 1502 range->op_private = (U8)(1 | (flags >> 8)); 1502 left->op_sibling = right; 1502 range->op_next = (OP*)range; 1502 flip = newUNOP(OP_FLIP, flags, (OP*)range); 1502 flop = newUNOP(OP_FLOP, 0, flip); 1502 o = newUNOP(OP_NULL, 0, flop); 1502 linklist(flop); 1502 range->op_next = leftstart; 1502 left->op_next = flip; 1502 right->op_next = flop; 1502 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 1502 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); 1502 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 1502 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); 1502 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 1502 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 1502 flip->op_next = o; 1502 if (!flip->op_private || !flop->op_private) 1324 linklist(o); /* blow off optimizer unless constant */ 1502 return o; } OP * Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) 1638 { 1638 OP* listop; 1638 OP* o; 1638 const bool once = block && block->op_flags & OPf_SPECIAL && 1638 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); 1638 (void)debuggable; 1638 if (expr) { 1638 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) ###### return block; /* do {} while 0 does once */ 1638 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { 322 expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 1316 } else if (expr->op_flags & OPf_KIDS) { 1214 const OP *k1 = ((UNOP*)expr)->op_first; 1214 const OP *k2 = (k1) ? k1->op_sibling : NULL; 1214 switch (expr->op_type) { case OP_NULL: 400 if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) ###### expr = newUNOP(OP_DEFINED, 0, expr); ###### break; case OP_SASSIGN: 47 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) ###### 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] */ 1638 if (!block) ###### block = newOP(OP_NULL, 0); 1638 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); 1638 o = new_logop(OP_AND, 0, &expr, &listop); 1638 if (listop) 1638 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); 1638 if (once && o != listop) 570 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; 1638 if (o == listop) ###### o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ 1638 o->op_flags |= flags; 1638 o = scope(o); 1638 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ 1638 return o; } OP * Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont, I32 has_my) 30083 { dVAR; 30083 OP *redo; 30083 OP *next = 0; 30083 OP *listop; 30083 OP *o; 30083 U8 loopflags = 0; 30083 (void)debuggable; 30083 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { 567 expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 29516 } else if (expr && (expr->op_flags & OPf_KIDS)) { 4776 const OP *k1 = ((UNOP*)expr)->op_first; 4776 const OP *k2 = (k1) ? k1->op_sibling : NULL; 4776 switch (expr->op_type) { case OP_NULL: 2024 if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 348 expr = newUNOP(OP_DEFINED, 0, expr); 348 break; case OP_SASSIGN: 95 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) ###### expr = newUNOP(OP_DEFINED, 0, expr); break; } } 30083 if (!block) ###### block = newOP(OP_NULL, 0); 30083 else if (cont || has_my) { 1769 block = scope(block); } 30083 if (cont) { 1062 next = LINKLIST(cont); } 30083 if (expr) { 26678 OP *unstack = newOP(OP_UNSTACK, 0); 26678 if (!next) 25616 next = unstack; 26678 cont = append_elem(OP_LINESEQ, cont, unstack); } 30083 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont); 30083 redo = LINKLIST(listop); 30083 if (expr) { 26678 PL_copline = (line_t)whileline; 26678 scalar(listop); 26678 o = new_logop(OP_AND, 0, &expr, &listop); 26678 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { ###### op_free(expr); /* oops, it's a while (0) */ ###### op_free((OP*)loop); ###### return Nullop; /* listop already freed by new_logop */ } 26678 if (listop) 26678 ((LISTOP*)listop)->op_last->op_next = (o == listop ? redo : LINKLIST(o)); } else 3405 o = listop; 30083 if (!loop) { 10067 NewOp(1101,loop,1,LOOP); 10067 loop->op_type = OP_ENTERLOOP; 10067 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP]; 10067 loop->op_private = 0; 10067 loop->op_next = (OP*)loop; } 30083 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o); 30083 loop->op_redoop = redo; 30083 loop->op_lastop = o; 30083 o->op_private |= loopflags; 30083 if (next) 26678 loop->op_nextop = next; else 3405 loop->op_nextop = o; 30083 o->op_flags |= flags; 30083 o->op_private |= (flags >> 8); 30083 return o; } OP * Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont) 20016 { dVAR; 20016 LOOP *loop; 20016 OP *wop; 20016 PADOFFSET padoff = 0; 20016 I32 iterflags = 0; 20016 I32 iterpflags = 0; 20016 if (sv) { 14391 if (sv->op_type == OP_RV2SV) { /* symbol table variable */ 23 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ 23 sv->op_type = OP_RV2GV; 23 sv->op_ppaddr = PL_ppaddr[OP_RV2GV]; } 14368 else if (sv->op_type == OP_PADSV) { /* private variable */ 14368 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */ 14368 padoff = sv->op_targ; 14368 sv->op_targ = 0; 14368 op_free(sv); 14368 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 { 5625 const I32 offset = pad_findmy("$_"); 5625 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { 5625 sv = newGVOP(OP_GV, 0, PL_defgv); } else { ###### padoff = offset; } } 20016 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { 12944 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART); 12944 iterflags |= OPf_STACKED; } 7072 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'. */ 1264 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; 1264 LOGOP* range = (LOGOP*) flip->op_first; 1264 OP* const left = range->op_first; 1264 OP* const right = left->op_sibling; 1264 LISTOP* listop; 1264 range->op_flags &= ~OPf_KIDS; 1264 range->op_first = Nullop; 1264 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); 1264 listop->op_first->op_next = range->op_next; 1264 left->op_next = range->op_other; 1264 right->op_next = (OP*)listop; 1264 listop->op_next = listop->op_first; 1264 op_free(expr); 1264 expr = (OP*)(listop); 1264 op_null(expr); 1264 iterflags |= OPf_STACKED; } else { 5808 expr = mod(force_list(expr), OP_GREPSTART); } 20016 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, append_elem(OP_LIST, expr, scalar(sv)))); 20016 assert(!loop->op_next); /* for my $x () sets OPpLVAL_INTRO; * for our $x () sets OPpOUR_INTRO */ 20016 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 20016 Renew(loop, 1, LOOP); #endif 20016 loop->op_targ = padoff; 20016 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0); 20016 PL_copline = forline; 20016 return newSTATEOP(0, label, wop); } OP* Perl_newLOOPEX(pTHX_ I32 type, OP *label) 14909 { 14909 OP *o; 14909 if (type != OP_GOTO || label->op_type == OP_CONST) { /* "last()" means "last" */ 7389 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) ###### o = newOP(type, OPf_SPECIAL); else { 7389 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST 7389 ? SvPVx_nolen_const(((SVOP*)label)->op_sv) : "")); } 7389 op_free(label); } else { /* Check whether it's going to be a goto &function */ 7520 if (label->op_type == OP_ENTERSUB && !(label->op_flags & OPf_STACKED)) 6880 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN)); 7520 o = newUNOP(type, OPf_STACKED, label); } 14909 PL_hints |= HINT_BLOCK_SCOPE; 14909 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) 142014 { 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 142014 if (!CvXSUB(cv) && CvROOT(cv)) { 90374 if (CvDEPTH(cv)) ###### Perl_croak(aTHX_ "Can't undef active subroutine"); 90374 ENTER; 90374 PAD_SAVE_SETNULLPAD(); 90374 op_free(CvROOT(cv)); 90374 CvROOT(cv) = Nullop; 90374 CvSTART(cv) = Nullop; 90374 LEAVE; } 142014 SvPOK_off((SV*)cv); /* forget prototype */ 142014 CvGV(cv) = Nullgv; 142014 pad_undef(cv); /* remove CvOUTSIDE unless this is an undef rather than a free */ 142014 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) { 104130 if (!CvWEAKOUTSIDE(cv)) 100213 SvREFCNT_dec(CvOUTSIDE(cv)); 104130 CvOUTSIDE(cv) = Nullcv; } 142014 if (CvCONST(cv)) { 3896 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); 3896 CvCONST_off(cv); } 142014 if (CvXSUB(cv)) { 24413 CvXSUB(cv) = 0; } /* delete all flags except WEAKOUTSIDE */ 142014 CvFLAGS(cv) &= CVf_WEAKOUTSIDE; } void Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p) 1988 { 1988 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { ###### SV* msg = sv_newmortal(); ###### SV* name = Nullsv; ###### if (gv) ###### gv_efullname3(name = sv_newmortal(), gv, Nullch); ###### sv_setpv(msg, "Prototype mismatch:"); ###### if (name) ###### Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name); ###### if (SvPOK(cv)) ###### Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv); else ###### Perl_sv_catpv(aTHX_ msg, ": none"); ###### sv_catpv(msg, " vs "); ###### if (p) ###### Perl_sv_catpvf(aTHX_ msg, "(%s)", p); else ###### sv_catpv(msg, "none"); ###### 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) 19416 { 19416 if (!cv || !CvCONST(cv)) 15871 return Nullsv; 3545 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) 4855 { 4855 SV *sv = Nullsv; 4855 if (!o) ###### return Nullsv; 4855 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) 3979 o = cLISTOPo->op_first->op_sibling; 11453 for (; o; o = o->op_next) { 8002 OPCODE type = o->op_type; 8002 if (sv && o->op_next == o) 2144 return sv; 5858 if (o->op_next != o) { 3355 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) 2354 continue; 2354 if (type == OP_DBSTATE) ###### continue; } 4857 if (type == OP_LEAVESUB || type == OP_RETURN) 4703 break; 4703 if (sv) ###### return Nullsv; 4703 if (type == OP_CONST && cSVOPo->op_sv) 2144 sv = cSVOPo->op_sv; 2559 else if (cv && type == OP_CONST) { ###### sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); ###### if (!sv) ###### return Nullsv; } 2559 else if (cv && type == OP_PADSV) { 953 if (CvCONST(cv)) { /* newly cloned anon */ 799 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); /* the candidate should have 1 ref from this pad and 1 ref * from the parent */ 799 if (!sv || SvREFCNT(sv) != 2) ###### return Nullsv; 799 sv = newSVsv(sv); 799 SvREADONLY_on(sv); 799 return sv; } else { 154 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE) 154 sv = &PL_sv_undef; /* an arbitrary non-null value */ } } else { 1606 return Nullsv; } } 306 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) 9 { 9 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block); } CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 96565 { dVAR; 96565 const char *aname; 96565 GV *gv; 96565 const char *ps; 96565 STRLEN ps_len; 96565 register CV *cv=0; 96565 SV *const_sv; 96565 I32 gv_fetch_flags; 96565 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch; 96565 if (proto) { 6315 assert(proto->op_type == OP_CONST); 6315 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len); } else 90250 ps = Nullch; 96565 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 96565 aname = Nullch; 96565 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; 96565 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); 96565 if (o) 92648 SAVEFREEOP(o); 96565 if (proto) 6315 SAVEFREEOP(proto); 96565 if (attrs) ###### SAVEFREEOP(attrs); 96565 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at maximum a prototype before. */ 6980 if (SvTYPE(gv) > SVt_NULL) { 17 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1) && ckWARN_d(WARN_PROTOTYPE)) { ###### Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype"); } 17 cv_ckproto((CV*)gv, NULL, ps); } 6980 if (ps) 604 sv_setpvn((SV*)gv, ps, ps_len); else 6376 sv_setiv((SV*)gv, -1); 6980 SvREFCNT_dec(PL_compcv); 6980 cv = PL_compcv = NULL; 6980 PL_sub_generation++; 6980 goto done; } 89585 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 89585 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) 85760 const_sv = Nullsv; else 3825 const_sv = op_const_sv(block, Nullcv); 89585 if (cv) { 1486 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 */ 1486 if (exists || SvPOK(cv)) 660 cv_ckproto(cv, gv, ps); /* already defined (or promised)? */ 1486 if (exists || GvASSUMECV(gv)) { 50 if (!block && !attrs) { ###### if (CvFLAGS(PL_compcv)) { /* might have had built-in attrs applied */ ###### CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); } /* just a "sub foo;" when &foo is already defined */ ###### SAVEFREESV(PL_compcv); ###### goto done; } /* ahem, death to those who redefine active sort subs */ 50 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv)) ###### Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); 50 if (block) { 50 if (ckWARN(WARN_REDEFINE) || (CvCONST(cv) && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv)))) { 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), CvCONST(cv) ? "Constant subroutine %s redefined" : "Subroutine %s redefined", name); 1 CopLINE_set(PL_curcop, oldline); } 50 SvREFCNT_dec(cv); 50 cv = Nullcv; } } } 89585 if (const_sv) { 2144 (void)SvREFCNT_inc(const_sv); 2144 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 { 2144 GvCV(gv) = Nullcv; 2144 cv = newCONSTSUB(NULL, name, const_sv); } 2144 op_free(block); 2144 SvREFCNT_dec(PL_compcv); 2144 PL_compcv = NULL; 2144 PL_sub_generation++; 2144 goto done; } 87441 if (attrs) { ###### HV *stash; ###### SV *rcv; /* Need to do a C * before we clobber PL_compcv. */ ###### if (cv && !block) { ###### rcv = (SV*)cv; /* Might have had built-in attributes applied -- propagate them. */ ###### CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); ###### if (CvGV(cv) && GvSTASH(CvGV(cv))) ###### 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 */ ###### rcv = (SV*)PL_compcv; ###### if (name && GvSTASH(gv)) ###### stash = GvSTASH(gv); else ###### stash = PL_curstash; } ###### apply_attrs(stash, rcv, attrs, FALSE); } 87441 if (cv) { /* must reuse cv if autoloaded */ 1436 if (!block) { /* got here with just attrs -- work done, so bug out */ ###### SAVEFREESV(PL_compcv); ###### goto done; } /* transfer PL_compcv to cv */ 1436 cv_undef(cv); 1436 CvFLAGS(cv) = CvFLAGS(PL_compcv); 1436 if (!CvWEAKOUTSIDE(cv)) 1436 SvREFCNT_dec(CvOUTSIDE(cv)); 1436 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); 1436 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); 1436 CvOUTSIDE(PL_compcv) = 0; 1436 CvPADLIST(cv) = CvPADLIST(PL_compcv); 1436 CvPADLIST(PL_compcv) = 0; /* inner references to PL_compcv must be fixed up ... */ 1436 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); /* ... before we throw it away */ 1436 SvREFCNT_dec(PL_compcv); 1436 PL_compcv = cv; 1436 if (PERLDB_INTER)/* Advice debugger on the new sub. */ ###### ++PL_sub_generation; } else { 86005 cv = PL_compcv; 86005 if (name) { 82088 GvCV(gv) = cv; 82088 GvCVGEN(gv) = 0; 82088 PL_sub_generation++; } } 87441 CvGV(cv) = gv; 87441 CvFILE_set_from_cop(cv, PL_curcop); 87441 CvSTASH(cv) = PL_curstash; 87441 if (ps) 3567 sv_setpvn((SV*)cv, ps, ps_len); 87441 if (PL_error_count) { ###### op_free(block); ###### block = Nullop; ###### if (name) { ###### const char *s = strrchr(name, ':'); ###### s = s ? s+1 : name; ###### if (strEQ(s, "BEGIN")) { ###### const char not_safe[] = ###### "BEGIN not safe after errors--compilation aborted"; ###### if (PL_in_eval & EVAL_KEEPERR) ###### Perl_croak(aTHX_ not_safe); else { /* force display of errors found but not reported */ ###### sv_catpv(ERRSV, not_safe); ###### Perl_croak(aTHX_ "%"SVf, ERRSV); } } } } 87441 if (!block) 15 goto done; 87426 if (CvLVALUE(cv)) { ###### CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, mod(scalarseq(block), OP_LEAVESUBLV)); } else { /* This makes sub {}; work as expected. */ 87426 if (block->op_type == OP_STUB) { 1045 op_free(block); 1045 block = newSTATEOP(0, Nullch, 0); } 87426 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); } 87426 CvROOT(cv)->op_private |= OPpREFCOUNTED; 87426 OpREFCNT_set(CvROOT(cv), 1); 87426 CvSTART(cv) = LINKLIST(CvROOT(cv)); 87426 CvROOT(cv)->op_next = 0; 87426 CALL_PEEP(CvSTART(cv)); /* now that optimizer has done its work, adjust pad values */ 87426 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); 87426 if (CvCLONE(cv)) { 548 assert(!CvCONST(cv)); 548 if (ps && !*ps && op_const_sv(block, cv)) 154 CvCONST_on(cv); } 87426 if (name || aname) { 83509 const char *s; 83509 const char *tname = (name ? name : aname); 83509 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { ###### SV *sv = NEWSV(0,0); ###### SV *tmpstr = sv_newmortal(); ###### GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV); ###### CV *pcv; ###### HV *hv; ###### Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld", CopFILE(PL_curcop), (long)PL_subline, (long)CopLINE(PL_curcop)); ###### gv_efullname3(tmpstr, gv, Nullch); ###### hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0); ###### hv = GvHVn(db_postponed); ###### 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); } } 83509 if ((s = strrchr(tname,':'))) 54 s++; else 83455 s = tname; 83509 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') 58626 goto done; 24883 if (strEQ(s, "BEGIN") && !PL_error_count) { 23564 const I32 oldscope = PL_scopestack_ix; 23564 ENTER; 23564 SAVECOPFILE(&PL_compiling); 23564 SAVECOPLINE(&PL_compiling); 23564 if (!PL_beginav) 522 PL_beginav = newAV(); 23564 DEBUG_x( dump_sub(gv) ); 23564 av_push(PL_beginav, (SV*)cv); 23564 GvCV(gv) = 0; /* cv has been hijacked */ 23564 call_list(oldscope, PL_beginav); 23564 PL_curcop = &PL_compiling; 23564 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 23564 LEAVE; } 1319 else if (strEQ(s, "END") && !PL_error_count) { 1 if (!PL_endav) 1 PL_endav = newAV(); 1 DEBUG_x( dump_sub(gv) ); 1 av_unshift(PL_endav, 1); 1 av_store(PL_endav, 0, (SV*)cv); 1 GvCV(gv) = 0; /* cv has been hijacked */ } 1318 else if (strEQ(s, "CHECK") && !PL_error_count) { ###### if (!PL_checkav) ###### PL_checkav = newAV(); ###### DEBUG_x( dump_sub(gv) ); ###### 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 */ } 1318 else if (strEQ(s, "INIT") && !PL_error_count) { ###### if (!PL_initav) ###### PL_initav = newAV(); ###### DEBUG_x( dump_sub(gv) ); ###### 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 */ } } done: 96565 PL_copline = NOLINE; 96565 LEAVE_SCOPE(floor); 96565 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) 2943 { dVAR; 2943 CV* cv; 2943 ENTER; 2943 SAVECOPLINE(PL_curcop); 2943 CopLINE_set(PL_curcop, PL_copline); 2943 SAVEHINTS(); 2943 PL_hints &= ~HINT_BLOCK_SCOPE; 2943 if (stash) { 799 SAVESPTR(PL_curstash); 799 SAVECOPSTASH(PL_curcop); 799 PL_curstash = stash; 799 CopSTASH_set(PL_curcop,stash); } 2943 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop))); 2943 CvXSUBANY(cv).any_ptr = sv; 2943 CvCONST_on(cv); 2943 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ 2943 if (stash) CopSTASH_free(PL_curcop); 2943 LEAVE; 2943 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) 24413 { 24413 GV *gv = gv_fetchpv(name ? name : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), 24413 GV_ADDMULTI, SVt_PVCV); 24413 register CV *cv; 24413 if (!subaddr) ###### Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename); 24413 if ((cv = (name ? GvCV(gv) : Nullcv))) { ###### if (GvCVGEN(gv)) { /* just a cached method */ ###### SvREFCNT_dec(cv); ###### cv = Nullcv; } ###### 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 */ ###### 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); } } } } ###### SvREFCNT_dec(cv); ###### cv = Nullcv; } } 24413 if (cv) /* must reuse cv if autoloaded */ ###### cv_undef(cv); else { 24413 cv = (CV*)NEWSV(1105,0); 24413 sv_upgrade((SV *)cv, SVt_PVCV); 24413 if (name) { 23614 GvCV(gv) = cv; 23614 GvCVGEN(gv) = 0; 23614 PL_sub_generation++; } } 24413 CvGV(cv) = gv; 24413 (void)gv_fetchfile(filename); 24413 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be an external constant string */ 24413 CvXSUB(cv) = subaddr; 24413 if (name) { 23614 const char *s = strrchr(name,':'); 23614 if (s) 21470 s++; else 2144 s = name; 23614 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') 23614 goto done; ###### if (strEQ(s, "BEGIN")) { ###### if (!PL_beginav) ###### PL_beginav = newAV(); ###### av_push(PL_beginav, (SV*)cv); ###### GvCV(gv) = 0; /* cv has been hijacked */ } ###### else if (strEQ(s, "END")) { ###### if (!PL_endav) ###### PL_endav = newAV(); ###### av_unshift(PL_endav, 1); ###### av_store(PL_endav, 0, (SV*)cv); ###### GvCV(gv) = 0; /* cv has been hijacked */ } ###### 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 */ } ###### 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 799 CvANON_on(cv); done: 24413 return cv; } void Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) ###### { ###### register CV *cv; ###### GV *gv; ###### if (o) ###### gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM); else ###### 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 ###### GvMULTI_on(gv); ###### if ((cv = GvFORM(gv))) { ###### if (ckWARN(WARN_REDEFINE)) { ###### const line_t oldline = CopLINE(PL_curcop); ###### if (PL_copline != NOLINE) ###### CopLINE_set(PL_curcop, PL_copline); ###### Perl_warner(aTHX_ packWARN(WARN_REDEFINE), o ? "Format %"SVf" redefined" : "Format STDOUT redefined" ,cSVOPo->op_sv); ###### CopLINE_set(PL_curcop, oldline); } ###### SvREFCNT_dec(cv); } ###### cv = PL_compcv; ###### GvFORM(gv) = cv; ###### CvGV(cv) = gv; ###### CvFILE_set_from_cop(cv, PL_curcop); ###### pad_tidy(padtidy_FORMAT); ###### CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); ###### CvROOT(cv)->op_private |= OPpREFCOUNTED; ###### OpREFCNT_set(CvROOT(cv), 1); ###### CvSTART(cv) = LINKLIST(CvROOT(cv)); ###### CvROOT(cv)->op_next = 0; ###### CALL_PEEP(CvSTART(cv)); ###### op_free(o); ###### PL_copline = NOLINE; ###### LEAVE_SCOPE(floor); } OP * Perl_newANONLIST(pTHX_ OP *o) 4825 { 4825 return newUNOP(OP_REFGEN, 0, mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN)); } OP * Perl_newANONHASH(pTHX_ OP *o) 6058 { 6058 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) 3917 { 3917 return newUNOP(OP_REFGEN, 0, newSVOP(OP_ANONCODE, 0, (SV*)newATTRSUB(floor, 0, proto, attrs, block))); } OP * Perl_oopsAV(pTHX_ OP *o) 23908 { dVAR; 23908 switch (o->op_type) { case OP_PADSV: 8390 o->op_type = OP_PADAV; 8390 o->op_ppaddr = PL_ppaddr[OP_PADAV]; 8390 return ref(o, OP_RV2AV); case OP_RV2SV: 15518 o->op_type = OP_RV2AV; 15518 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 15518 ref(o, OP_RV2AV); 15518 break; default: ###### if (ckWARN_d(WARN_INTERNAL)) ###### Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); 15518 break; } 15518 return o; } OP * Perl_oopsHV(pTHX_ OP *o) 67351 { dVAR; 67351 switch (o->op_type) { case OP_PADSV: case OP_PADAV: 21978 o->op_type = OP_PADHV; 21978 o->op_ppaddr = PL_ppaddr[OP_PADHV]; 21978 return ref(o, OP_RV2HV); case OP_RV2SV: case OP_RV2AV: 45373 o->op_type = OP_RV2HV; 45373 o->op_ppaddr = PL_ppaddr[OP_RV2HV]; 45373 ref(o, OP_RV2HV); 45373 break; default: ###### if (ckWARN_d(WARN_INTERNAL)) ###### Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); 45373 break; } 45373 return o; } OP * Perl_newAVREF(pTHX_ OP *o) 176367 { dVAR; 176367 if (o->op_type == OP_PADANY) { 69200 o->op_type = OP_PADAV; 69200 o->op_ppaddr = PL_ppaddr[OP_PADAV]; 69200 return o; } 107167 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV) && ckWARN(WARN_DEPRECATED)) { ###### Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Using an array as a reference is deprecated"); } 107167 return newUNOP(OP_RV2AV, 0, scalar(o)); } OP * Perl_newGVREF(pTHX_ I32 type, OP *o) 32719 { 32719 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT) 5887 return newUNOP(OP_NULL, 0, o); 26832 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type); } OP * Perl_newHVREF(pTHX_ OP *o) 68499 { dVAR; 68499 if (o->op_type == OP_PADANY) { 13343 o->op_type = OP_PADHV; 13343 o->op_ppaddr = PL_ppaddr[OP_PADHV]; 13343 return o; } 55156 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV) && ckWARN(WARN_DEPRECATED)) { ###### Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Using a hash as a reference is deprecated"); } 55156 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) 113417 { 113417 return newUNOP(OP_RV2CV, flags, scalar(o)); } OP * Perl_newSVREF(pTHX_ OP *o) 1130743 { dVAR; 1130743 if (o->op_type == OP_PADANY) { 853136 o->op_type = OP_PADSV; 853136 o->op_ppaddr = PL_ppaddr[OP_PADSV]; 853136 return o; } 277607 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) { ###### o->op_flags |= OPpDONE_SVREF; ###### return o; } 277607 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) 3917 { 3917 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type); 3917 cSVOPo->op_sv = Nullsv; 3917 return o; } OP * Perl_ck_bitop(pTHX_ OP *o) 16637 { #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) 16637 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 16637 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)) { 3412 const OP * const left = cBINOPo->op_first; 3412 const OP * const right = left->op_sibling; 3412 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)) ###### if (ckWARN(WARN_PRECEDENCE)) ###### 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 ? '&' : '^' ); } 16637 return o; } OP * Perl_ck_concat(pTHX_ OP *o) 215069 { 215069 const OP *kid = cUNOPo->op_first; 215069 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) && !(kUNOP->op_first->op_flags & OPf_MOD)) 110827 o->op_flags |= OPf_STACKED; 215069 return o; } OP * Perl_ck_spair(pTHX_ OP *o) 45359 { dVAR; 45359 if (o->op_flags & OPf_KIDS) { 45045 OP* newop; 45045 OP* kid; 45045 const OPCODE type = o->op_type; 45045 o = modkids(ck_fun(o), type); 45045 kid = cUNOPo->op_first; 45045 newop = kUNOP->op_first->op_sibling; 45045 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)) { 28318 return o; } 16727 op_free(kUNOP->op_first); 16727 kUNOP->op_first = newop; } 17041 o->op_ppaddr = PL_ppaddr[++o->op_type]; 17041 return ck_fun(o); } OP * Perl_ck_delete(pTHX_ OP *o) 1660 { 1660 o = ck_fun(o); 1660 o->op_private = 0; 1660 if (o->op_flags & OPf_KIDS) { 1660 OP *kid = cUNOPo->op_first; 1660 switch (kid->op_type) { case OP_ASLICE: ###### o->op_flags |= OPf_SPECIAL; /* FALL THROUGH */ case OP_HSLICE: 42 o->op_private |= OPpSLICE; 42 break; case OP_AELEM: ###### o->op_flags |= OPf_SPECIAL; /* FALL THROUGH */ case OP_HELEM: ###### break; default: ###### Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", OP_DESC(o)); } 1660 op_null(kid); } 1660 return o; } OP * Perl_ck_die(pTHX_ OP *o) 8846 { #ifdef VMS if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; #endif 8846 return ck_fun(o); } OP * Perl_ck_eof(pTHX_ OP *o) 49 { 49 const I32 type = o->op_type; 49 if (o->op_flags & OPf_KIDS) { 48 if (cLISTOPo->op_first->op_type == OP_STUB) { ###### op_free(o); ###### o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); } 48 return ck_fun(o); } 1 return o; } OP * Perl_ck_eval(pTHX_ OP *o) 5930 { dVAR; 5930 PL_hints |= HINT_BLOCK_SCOPE; 5930 if (o->op_flags & OPf_KIDS) { 5930 SVOP *kid = (SVOP*)cUNOPo->op_first; 5930 if (!kid) { ###### o->op_flags &= ~OPf_KIDS; ###### op_null(o); } 5930 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { 3455 LOGOP *enter; 3455 cUNOPo->op_first = 0; 3455 op_free(o); 3455 NewOp(1101, enter, 1, LOGOP); 3455 enter->op_type = OP_ENTERTRY; 3455 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY]; 3455 enter->op_private = 0; /* establish postfix order */ 3455 enter->op_next = (OP*)enter; 3455 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); 3455 o->op_type = OP_LEAVETRY; 3455 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; 3455 enter->op_other = o; 3455 return o; } else { 2475 scalar((OP*)kid); 2475 PL_cv_has_eval = 1; } } else { ###### op_free(o); ###### o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP()); } 2475 o->op_targ = (PADOFFSET)PL_hints; 2475 return o; } OP * Perl_ck_exit(pTHX_ OP *o) 729 { #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 729 return ck_fun(o); } OP * Perl_ck_exec(pTHX_ OP *o) 611 { 611 if (o->op_flags & OPf_STACKED) { ###### OP *kid; ###### o = ck_fun(o); ###### kid = cUNOPo->op_first->op_sibling; ###### if (kid->op_type == OP_RV2GV) ###### op_null(kid); } else 611 o = listkids(o); 611 return o; } OP * Perl_ck_exists(pTHX_ OP *o) 6042 { 6042 o = ck_fun(o); 6042 if (o->op_flags & OPf_KIDS) { 6042 OP *kid = cUNOPo->op_first; 6042 if (kid->op_type == OP_ENTERSUB) { ###### (void) ref(kid, o->op_type); ###### if (kid->op_type != OP_RV2CV && !PL_error_count) ###### Perl_croak(aTHX_ "%s argument is not a subroutine name", OP_DESC(o)); ###### o->op_private |= OPpEXISTS_SUB; } 6042 else if (kid->op_type == OP_AELEM) ###### o->op_flags |= OPf_SPECIAL; 6042 else if (kid->op_type != OP_HELEM) ###### Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element", OP_DESC(o)); 6042 op_null(kid); } 6042 return o; } OP * Perl_ck_rvconst(pTHX_ register OP *o) 606434 { dVAR; 606434 SVOP *kid = (SVOP*)cUNOPo->op_first; 606434 o->op_private |= (PL_hints & HINT_STRICT_REFS); 606434 if (kid->op_type == OP_CONST) { 481156 int iscv; 481156 GV *gv; 481156 SV * const kidsv = kid->op_sv; /* Is it a constant from cv_const_sv()? */ 481156 if (SvROK(kidsv) && SvREADONLY(kidsv)) { ###### SV *rsv = SvRV(kidsv); ###### const int svtype = SvTYPE(rsv); ###### const char *badtype = Nullch; ###### switch (o->op_type) { case OP_RV2SV: ###### if (svtype > SVt_PVMG) ###### badtype = "a SCALAR"; ###### break; case OP_RV2AV: ###### if (svtype != SVt_PVAV) ###### badtype = "an ARRAY"; ###### break; case OP_RV2HV: ###### if (svtype != SVt_PVHV) ###### badtype = "a HASH"; ###### break; case OP_RV2CV: ###### if (svtype != SVt_PVCV) ###### badtype = "a CODE"; break; } ###### if (badtype) ###### Perl_croak(aTHX_ "Constant is not %s reference", badtype); ###### return o; } 481156 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { 40124 const char *badthing = Nullch; 40124 switch (o->op_type) { case OP_RV2SV: ###### badthing = "a SCALAR"; ###### break; case OP_RV2AV: ###### badthing = "an ARRAY"; ###### break; case OP_RV2HV: ###### badthing = "a HASH"; break; } 40124 if (badthing) ###### 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. */ 481156 iscv = (o->op_type == OP_RV2CV) * 2; 481156 do { 481156 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); 481156 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++); 481156 if (gv) { 481156 kid->op_type = OP_GV; 481156 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 481156 kid->op_sv = SvREFCNT_inc(gv); #endif 481156 kid->op_private = 0; 481156 kid->op_ppaddr = PL_ppaddr[OP_GV]; } } 606434 return o; } OP * Perl_ck_ftst(pTHX_ OP *o) 27470 { dVAR; 27470 const I32 type = o->op_type; 27470 if (o->op_flags & OPf_REF) { /* nothing */ } 23800 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { 22835 SVOP *kid = (SVOP*)cUNOPo->op_first; 22835 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 3670 OP *newop = newGVOP(type, OPf_REF, 3670 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO)); 3670 op_free(o); 3670 o = newop; 3670 return o; } else { 19165 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o)) ###### o->op_private |= OPpFT_ACCESS; } 19165 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst) && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT) ###### o->op_private |= OPpFT_STACKED; } else { 965 op_free(o); 965 if (type == OP_FTTTY) ###### o = newGVOP(type, OPf_REF, PL_stdingv); else 965 o = newUNOP(type, 0, newDEFSVOP()); } 23800 return o; } OP * Perl_ck_fun(pTHX_ OP *o) 491136 { 491136 const int type = o->op_type; 491136 register I32 oa = PL_opargs[type] >> OASHIFT; 491136 if (o->op_flags & OPf_STACKED) { ###### if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) ###### oa &= ~OA_OPTIONAL; else ###### return no_fh_allowed(o); } 491136 if (o->op_flags & OPf_KIDS) { 481321 OP **tokid = &cLISTOPo->op_first; 481321 register OP *kid = cLISTOPo->op_first; 481321 OP *sibl; 481321 I32 numargs = 0; 481321 if (kid->op_type == OP_PUSHMARK || (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) { 244728 tokid = &kid->op_sibling; 244728 kid = kid->op_sibling; } 481321 if (!kid && PL_opargs[type] & OA_DEFGV) ###### *tokid = kid = newDEFSVOP(); 1042025 while (oa && kid) { 560704 numargs++; 560704 sibl = kid->op_sibling; 560704 switch (oa & 7) { case OA_SCALAR: /* list seen where single (scalar) arg expected? */ 360567 if (numargs == 1 && !(oa >> 4) && kid->op_type == OP_LIST && type != OP_SCALAR) { ###### return too_many_arguments(o,PL_op_desc[type]); } 360567 scalar(kid); 360567 break; case OA_LIST: 120660 if (oa < 16) { 120660 kid = 0; 120660 continue; } else ###### list(kid); ###### break; case OA_AVREF: 43289 if ((type == OP_PUSH || type == OP_UNSHIFT) && !kid->op_sibling && ckWARN(WARN_SYNTAX)) ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Useless use of %s with no values", PL_op_desc[type]); 43289 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { ###### OP *newop = newAVREF(newGVOP(OP_GV, 0, ###### gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) )); ###### if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) ###### 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]); ###### op_free(kid); ###### kid = newop; ###### kid->op_sibling = sibl; ###### *tokid = kid; } 43289 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) ###### bad_type(numargs, "array", PL_op_desc[type], kid); 43289 mod(kid, type); 43289 break; case OA_HVREF: 6595 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { ###### OP *newop = newHVREF(newGVOP(OP_GV, 0, ###### gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) )); ###### if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) ###### 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]); ###### op_free(kid); ###### kid = newop; ###### kid->op_sibling = sibl; ###### *tokid = kid; } 6595 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) ###### bad_type(numargs, "hash", PL_op_desc[type], kid); 6595 mod(kid, type); 6595 break; case OA_CVREF: { 10850 OP *newop = newUNOP(OP_NULL, 0, kid); 10850 kid->op_sibling = 0; 10850 linklist(kid); 10850 newop->op_next = newop; 10850 kid = newop; 10850 kid->op_sibling = sibl; 10850 *tokid = kid; } 10850 break; case OA_FILEREF: 16114 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) { 16068 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 9826 OP *newop = newGVOP(OP_GV, 0, 9826 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) ); 9826 if (!(o->op_private & 1) && /* if not unop */ kid == cLISTOPo->op_last) 695 cLISTOPo->op_last = newop; 9826 op_free(kid); 9826 kid = newop; } 6242 else if (kid->op_type == OP_READLINE) { /* neophyte patrol: open(), close() etc. */ ###### bad_type(numargs, "HANDLE", OP_DESC(o), kid); } else { 6242 I32 flags = OPf_SPECIAL; 6242 I32 priv = 0; 6242 PADOFFSET targ = 0; /* is this op a FH constructor? */ 6242 if (is_handle_constructor(o,numargs)) { 1856 const char *name = Nullch; 1856 STRLEN len = 0; 1856 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 */ 1856 priv = OPpDEREF; 1856 if (kid->op_type == OP_PADSV) { 1670 name = PAD_COMPNAME_PV(kid->op_targ); /* SvCUR of a pad namesv can't be trusted * (see PL_generation), so calc its length * manually */ 1670 if (name) 1670 len = strlen(name); } 186 else if (kid->op_type == OP_RV2SV && kUNOP->op_first->op_type == OP_GV) { 94 GV *gv = cGVOPx_gv(kUNOP->op_first); 94 name = GvNAME(gv); 94 len = GvNAMELEN(gv); } 92 else if (kid->op_type == OP_AELEM || kid->op_type == OP_HELEM) { 47 OP *op; 47 name = 0; 47 if ((op = ((BINOP*)kid)->op_first)) { 47 SV *tmpstr = Nullsv; 47 const char *a = kid->op_type == OP_AELEM ? 47 "[]" : "{}"; 47 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{} */ ###### GV *gv = cGVOPx_gv(op); ###### if (gv) ###### tmpstr = Perl_newSVpvf(aTHX_ "%s%c...%c", GvNAME(gv), a[0], a[1]); } 47 else if (op->op_type == OP_PADAV || op->op_type == OP_PADHV) { /* lexicalvar $a[] or $h{} */ 47 const char *padname = 47 PAD_COMPNAME_PV(op->op_targ); 47 if (padname) 47 tmpstr = Perl_newSVpvf(aTHX_ "%s%c...%c", padname + 1, a[0], a[1]); } 47 if (tmpstr) { 47 name = SvPV_const(tmpstr, len); 47 sv_2mortal(tmpstr); } } 47 if (!name) { ###### name = "__ANONIO__"; ###### len = 10; } 47 mod(kid, type); } 1856 if (name) { 1811 SV *namesv; 1811 targ = pad_alloc(OP_RV2GV, SVs_PADTMP); 1811 namesv = PAD_SVl(targ); 1811 SvUPGRADE(namesv, SVt_PV); 1811 if (*name != '$') 141 sv_setpvn(namesv, "$", 1); 1811 sv_catpvn(namesv, name, len); } } 6242 kid->op_sibling = 0; 6242 kid = newUNOP(OP_RV2GV, flags, scalar(kid)); 6242 kid->op_targ = targ; 6242 kid->op_private |= priv; } 16068 kid->op_sibling = sibl; 16068 *tokid = kid; } 16114 scalar(kid); 16114 break; case OA_SCALARREF: 2629 mod(scalar(kid), type); break; } 440044 oa >>= 4; 440044 tokid = &kid->op_sibling; 440044 kid = kid->op_sibling; } 481321 o->op_private |= numargs; 481321 if (kid) ###### return too_many_arguments(o,OP_DESC(o)); 481321 listkids(o); } 9815 else if (PL_opargs[type] & OA_DEFGV) { 1020 op_free(o); 1020 return newUNOP(type, 0, newDEFSVOP()); } 490116 if (oa) { 163267 while (oa & OA_OPTIONAL) 18974 oa >>= 4; 144293 if (oa && oa != OA_LIST) ###### return too_few_arguments(o,OP_DESC(o)); } 490116 return o; } OP * Perl_ck_glob(pTHX_ OP *o) 279 { dVAR; 279 GV *gv; 279 o = ck_fun(o); 279 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) ###### append_elem(OP_GLOB, o, newDEFSVOP()); 279 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvCVu(gv) && GvIMPORTED_CV(gv))) { 279 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); } #if !defined(PERL_EXTERNAL_GLOB) /* XXX this can be tightened up and made more failsafe. */ if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { GV *glob_gv; ENTER; Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv); gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV); GvCV(gv) = GvCV(glob_gv); (void)SvREFCNT_inc((SV*)GvCV(gv)); GvIMPORTED_CV_on(gv); LEAVE; } #endif /* PERL_EXTERNAL_GLOB */ 279 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { ###### append_elem(OP_GLOB, o, newSVOP(OP_CONST, 0, newSViv(PL_glob_index++))); ###### o->op_type = OP_LIST; ###### o->op_ppaddr = PL_ppaddr[OP_LIST]; ###### cLISTOPo->op_first->op_type = OP_PUSHMARK; ###### cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK]; ###### cLISTOPo->op_first->op_targ = 0; ###### o = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, o, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv))))); ###### o = newUNOP(OP_NULL, 0, ck_subr(o)); ###### o->op_targ = OP_GLOB; /* hint at what it used to be */ ###### return o; } 279 gv = newGVgen("main"); 279 gv_IOadd(gv); 279 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); 279 scalarkids(o); 279 return o; } OP * Perl_ck_grep(pTHX_ OP *o) 10850 { dVAR; 10850 LOGOP *gwop; 10850 OP *kid; 10850 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; 10850 I32 offset; 10850 o->op_ppaddr = PL_ppaddr[OP_GREPSTART]; 10850 NewOp(1101, gwop, 1, LOGOP); 10850 if (o->op_flags & OPf_STACKED) { 5064 OP* k; 5064 o = ck_sort(o); 5064 kid = cLISTOPo->op_first->op_sibling; 5064 if (!cUNOPx(kid)->op_next) ###### Perl_croak(aTHX_ "panic: ck_grep"); 10128 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) { 5064 kid = k; } 5064 kid->op_next = (OP*)gwop; 5064 o->op_flags &= ~OPf_STACKED; } 10850 kid = cLISTOPo->op_first->op_sibling; 10850 if (type == OP_MAPWHILE) 6507 list(kid); else 4343 scalar(kid); 10850 o = ck_fun(o); 10850 if (PL_error_count) ###### return o; 10850 kid = cLISTOPo->op_first->op_sibling; 10850 if (kid->op_type != OP_NULL) ###### Perl_croak(aTHX_ "panic: ck_grep"); 10850 kid = kUNOP->op_first; 10850 gwop->op_type = type; 10850 gwop->op_ppaddr = PL_ppaddr[type]; 10850 gwop->op_first = listkids(o); 10850 gwop->op_flags |= OPf_KIDS; 10850 gwop->op_other = LINKLIST(kid); 10850 kid->op_next = (OP*)gwop; 10850 offset = pad_findmy("$_"); 10850 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { 10850 o->op_private = gwop->op_private = 0; 10850 gwop->op_targ = pad_alloc(type, SVs_PADTMP); } else { ###### o->op_private = gwop->op_private = OPpGREP_LEX; ###### gwop->op_targ = o->op_targ = offset; } 10850 kid = cLISTOPo->op_first->op_sibling; 10850 if (!kid || !kid->op_sibling) ###### return too_few_arguments(o,OP_DESC(o)); 24525 for (kid = kid->op_sibling; kid; kid = kid->op_sibling) 13675 mod(kid, OP_GREPSTART); 10850 return (OP*)gwop; } OP * Perl_ck_index(pTHX_ OP *o) 1014 { 1014 if (o->op_flags & OPf_KIDS) { 1014 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 1014 if (kid) 1014 kid = kid->op_sibling; /* get past "big" */ 1014 if (kid && kid->op_type == OP_CONST) 690 fbm_compile(((SVOP*)kid)->op_sv, 0); } 1014 return ck_fun(o); } OP * Perl_ck_lengthconst(pTHX_ OP *o) 5594 { /* XXX length optimization goes here */ 5594 return ck_fun(o); } OP * Perl_ck_lfun(pTHX_ OP *o) 16798 { 16798 const OPCODE type = o->op_type; 16798 return modkids(ck_fun(o), type); } OP * Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ 35094 { 35094 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) { 10285 switch (cUNOPo->op_first->op_type) { case OP_RV2AV: /* This is needed for if (defined %stash::) to work. Do not break Tk. */ ###### break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ ###### Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "defined(@array) is deprecated"); ###### Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "\t(Maybe you should just omit the defined()?)\n"); ###### break; case OP_RV2HV: /* This is needed for if (defined %stash::) to work. Do not break Tk. */ ###### break; /* Globals via GV can be undef */ case OP_PADHV: ###### Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "defined(%%hash) is deprecated"); ###### Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "\t(Maybe you should just omit the defined()?)\n"); break; default: /* no warning */ 35094 break; } } 35094 return ck_rfun(o); } OP * Perl_ck_rfun(pTHX_ OP *o) 35094 { 35094 const OPCODE type = o->op_type; 35094 return refkids(ck_fun(o), type); } OP * Perl_ck_listiob(pTHX_ OP *o) 18501 { 18501 register OP *kid; 18501 kid = cLISTOPo->op_first; 18501 if (!kid) { ###### o = force_list(o); ###### kid = cLISTOPo->op_first; } 18501 if (kid->op_type == OP_PUSHMARK) 18501 kid = kid->op_sibling; 18501 if (kid && o->op_flags & OPf_STACKED) 7937 kid = kid->op_sibling; 10564 else if (kid && !kid->op_sibling) { /* print HANDLE; */ 9817 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) { 3 o->op_flags |= OPf_STACKED; /* make it a filehandle */ 3 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); 3 cLISTOPo->op_first->op_sibling = kid; 3 cLISTOPo->op_last = kid; 3 kid = kid->op_sibling; } } 18501 if (!kid) 283 append_elem(o->op_type, o, newDEFSVOP()); 18501 return listkids(o); } OP * Perl_ck_sassign(pTHX_ OP *o) 217840 { 217840 OP *kid = cLISTOPo->op_first; /* has a disposable target? */ 217840 if ((PL_opargs[kid->op_type] & OA_TARGLEX) && !(kid->op_flags & OPf_STACKED) /* Cannot steal the second time! */ && !(kid->op_private & OPpTARGET_MY)) { 15287 OP *kkid = kid->op_sibling; /* Can just relocate the target. */ 15287 if (kkid && kkid->op_type == OP_PADSV && !(kkid->op_private & OPpLVAL_INTRO)) { 8608 kid->op_targ = kkid->op_targ; 8608 kkid->op_targ = 0; /* Now we do not need PADSV and SASSIGN. */ 8608 kid->op_sibling = o->op_sibling; /* NULL */ 8608 cLISTOPo->op_first = NULL; 8608 op_free(o); 8608 op_free(kkid); 8608 kid->op_private |= OPpTARGET_MY; /* Used for context settings */ 8608 return kid; } } /* optimise C to C */ 209232 if (kid->op_type == OP_UNDEF) { 1085 OP *kkid = kid->op_sibling; 1085 if (kkid && kkid->op_type == OP_PADSV && (kkid->op_private & OPpLVAL_INTRO)) { 7 cLISTOPo->op_first = NULL; 7 kid->op_sibling = NULL; 7 op_free(o); 7 op_free(kid); 7 return kkid; } } 209225 return o; } OP * Perl_ck_match(pTHX_ OP *o) 71465 { 71465 if (o->op_type != OP_QR) { 70818 const I32 offset = pad_findmy("$_"); 70818 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) { ###### o->op_targ = offset; ###### o->op_private |= OPpTARGET_MY; } } 71465 if (o->op_type == OP_MATCH || o->op_type == OP_QR) 46080 o->op_private |= OPpRUNTIME; 71465 return o; } OP * Perl_ck_method(pTHX_ OP *o) 30963 { 30963 OP *kid = cUNOPo->op_first; 30963 if (kid->op_type == OP_CONST) { 30838 SV* sv = kSVOP->op_sv; 30838 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) { 30567 OP *cmop; 30567 if (!SvREADONLY(sv) || !SvFAKE(sv)) { 30567 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0); } else { ###### kSVOP->op_sv = Nullsv; } 30567 cmop = newSVOP(OP_METHOD_NAMED, 0, sv); 30567 op_free(o); 30567 return cmop; } } 396 return o; } OP * Perl_ck_null(pTHX_ OP *o) 4850472 { 4850472 return o; } OP * Perl_ck_open(pTHX_ OP *o) 4551 { 4551 HV *table = GvHV(PL_hintgv); 4551 if (table) { ###### SV **svp; ###### I32 mode; ###### svp = hv_fetch(table, "open_IN", 7, FALSE); ###### if (svp && *svp) { ###### mode = mode_from_discipline(*svp); ###### if (mode & O_BINARY) ###### o->op_private |= OPpOPEN_IN_RAW; ###### else if (mode & O_TEXT) ###### o->op_private |= OPpOPEN_IN_CRLF; } ###### svp = hv_fetch(table, "open_OUT", 8, FALSE); ###### if (svp && *svp) { ###### mode = mode_from_discipline(*svp); 4551 if (mode & O_BINARY) 4551 o->op_private |= OPpOPEN_OUT_RAW; 4551 else if (mode & O_TEXT) 4551 o->op_private |= OPpOPEN_OUT_CRLF; } } 4551 if (o->op_type == OP_BACKTICK) 779 return o; { /* In case of three-arg dup open remove strictness * from the last arg if it is a bareword. */ 3772 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */ 3772 OP *last = cLISTOPx(o)->op_last; /* The bareword. */ 3772 OP *oa; 3772 const char *mode; 3772 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. */ ###### last->op_private &= ~OPpCONST_STRICT; } 3772 return ck_fun(o); } OP * Perl_ck_repeat(pTHX_ OP *o) 1844 { 1844 if (cBINOPo->op_first->op_flags & OPf_PARENS) { 1558 o->op_private |= OPpREPEAT_DOLIST; 1558 cBINOPo->op_first = force_list(cBINOPo->op_first); } else 286 scalar(o); 1844 return o; } OP * Perl_ck_require(pTHX_ OP *o) 47694 { 47694 GV* gv; 47694 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ 47694 SVOP *kid = (SVOP*)cUNOPo->op_first; 47694 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 42123 SV *sv = kid->op_sv; 42123 U32 was_readonly = SvREADONLY(sv); 42123 char *s; 42123 if (was_readonly) { 42123 if (SvFAKE(sv)) { ###### sv_force_normal_flags(sv, 0); ###### assert(!SvREADONLY(sv)); ###### was_readonly = 0; } else { 42123 SvREADONLY_off(sv); } } 339944 for (s = SvPVX(sv); *s; s++) { 297821 if (*s == ':' && s[1] == ':') { 10492 *s = '/'; 10492 Move(s+2, s+1, strlen(s+2)+1, char); 10492 SvCUR_set(sv, SvCUR(sv) - 1); } } 42123 sv_catpvn(sv, ".pm", 3); 42123 SvFLAGS(sv) |= was_readonly; } } /* handle override, if any */ 47694 gv = gv_fetchpv("require", FALSE, SVt_PVCV); 47694 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) 47694 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV); 47694 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { ###### OP *kid = cUNOPo->op_first; ###### cUNOPo->op_first = 0; ###### op_free(o); ###### return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, kid, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv)))))); } 47694 return ck_fun(o); } OP * Perl_ck_return(pTHX_ OP *o) 44139 { 44139 if (CvLVALUE(PL_compcv)) { ###### OP *kid; ###### for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) ###### mod(kid, OP_LEAVESUBLV); } 44139 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) 281 { dVAR; 281 OP* kid; 281 if (o->op_flags & OPf_KIDS) { 281 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 281 if (kid && kid->op_sibling) { ###### o->op_type = OP_SSELECT; ###### o->op_ppaddr = PL_ppaddr[OP_SSELECT]; ###### o = ck_fun(o); ###### return fold_constants(o); } } 281 o = ck_fun(o); 281 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 281 if (kid && kid->op_type == OP_RV2GV) 184 kid->op_private &= ~HINT_STRICT_REFS; 281 return o; } OP * Perl_ck_shift(pTHX_ OP *o) 44591 { 44591 const I32 type = o->op_type; 44591 if (!(o->op_flags & OPf_KIDS)) { 19681 OP *argop; 19681 op_free(o); 19681 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv))); 19681 return newUNOP(type, 0, scalar(argop)); } 24910 return scalar(modkids(ck_fun(o), type)); } OP * Perl_ck_sort(pTHX_ OP *o) 7997 { 7997 OP *firstkid; 7997 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) 823 simplify_sort(o); 7997 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 7997 if (o->op_flags & OPf_STACKED) { /* may have been cleared */ 5880 OP *k = NULL; 5880 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ 5880 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { 5698 linklist(kid); 5698 if (kid->op_type == OP_SCOPE) { 3432 k = kid->op_next; 3432 kid->op_next = 0; } 2266 else if (kid->op_type == OP_LEAVE) { 2266 if (o->op_type == OP_SORT) { 50 op_null(kid); /* wipe out leave */ 50 kid->op_next = kid; 2050 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { 2000 if (k->op_next == kid) 50 k->op_next = 0; /* don't descend into loops */ 1950 else if (k->op_type == OP_ENTERLOOP || k->op_type == OP_ENTERITER) { 84 k = cLOOPx(k)->op_lastop; } } } else 2216 kid->op_next = 0; /* just disconnect the leave */ 2266 k = kLISTOP->op_first; } 5698 CALL_PEEP(k); 5698 kid = firstkid; 5698 if (o->op_type == OP_SORT) { /* provide scalar context for comparison function/block */ 634 kid = scalar(kid); 634 kid->op_next = kid; } else 5064 kid->op_next = k; 5698 o->op_flags |= OPf_SPECIAL; } 182 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) ###### op_null(firstkid); 5880 firstkid = firstkid->op_sibling; } /* provide list context for arguments */ 7997 if (o->op_type == OP_SORT) 2933 list(firstkid); 7997 return o; } STATIC void S_simplify_sort(pTHX_ OP *o) 823 { 823 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 823 OP *k; 823 int descending; 823 GV *gv; 823 const char *gvname; 823 if (!(o->op_flags & OPf_STACKED)) ###### return; 823 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV)); 823 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV)); 823 kid = kUNOP->op_first; /* get past null */ 823 if (kid->op_type != OP_SCOPE) 232 return; 591 kid = kLISTOP->op_last; /* get past scope */ 591 switch(kid->op_type) { case OP_NCMP: case OP_I_NCMP: case OP_SCMP: 564 break; default: 564 return; } 564 k = kid; /* remember this node*/ 564 if (kBINOP->op_first->op_type != OP_RV2SV) 557 return; 7 kid = kBINOP->op_first; /* get past cmp */ 7 if (kUNOP->op_first->op_type != OP_GV) ###### return; 7 kid = kUNOP->op_first; /* get past rv2sv */ 7 gv = kGVOP_gv; 7 if (GvSTASH(gv) != PL_curstash) ###### return; 7 gvname = GvNAME(gv); 7 if (*gvname == 'a' && gvname[1] == '\0') 7 descending = 0; ###### else if (*gvname == 'b' && gvname[1] == '\0') ###### descending = 1; else 7 return; 7 kid = k; /* back to cmp */ 7 if (kBINOP->op_last->op_type != OP_RV2SV) ###### return; 7 kid = kBINOP->op_last; /* down to 2nd arg */ 7 if (kUNOP->op_first->op_type != OP_GV) ###### return; 7 kid = kUNOP->op_first; /* get past rv2sv */ 7 gv = kGVOP_gv; 7 if (GvSTASH(gv) != PL_curstash) ###### return; 7 gvname = GvNAME(gv); 7 if ( descending ? !(*gvname == 'a' && gvname[1] == '\0') : !(*gvname == 'b' && gvname[1] == '\0')) 7 return; 7 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); 7 if (descending) ###### o->op_private |= OPpSORT_DESCEND; 7 if (k->op_type == OP_NCMP) 7 o->op_private |= OPpSORT_NUMERIC; 7 if (k->op_type == OP_I_NCMP) ###### o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; 7 kid = cLISTOPo->op_first->op_sibling; 7 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ 7 op_free(kid); /* then delete it */ } OP * Perl_ck_split(pTHX_ OP *o) 4498 { dVAR; 4498 register OP *kid; 4498 if (o->op_flags & OPf_STACKED) ###### return no_fh_allowed(o); 4498 kid = cLISTOPo->op_first; 4498 if (kid->op_type != OP_NULL) ###### Perl_croak(aTHX_ "panic: ck_split"); 4498 kid = kid->op_sibling; 4498 op_free(cLISTOPo->op_first); 4498 cLISTOPo->op_first = kid; 4498 if (!kid) { ###### cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1)); ###### cLISTOPo->op_last = kid; /* There was only one element previously */ } 4498 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { 1380 OP *sibl = kid->op_sibling; 1380 kid->op_sibling = 0; 1380 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0); 1380 if (cLISTOPo->op_first == cLISTOPo->op_last) ###### cLISTOPo->op_last = kid; 1380 cLISTOPo->op_first = kid; 1380 kid->op_sibling = sibl; } 4498 kid->op_type = OP_PUSHRE; 4498 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE]; 4498 scalar(kid); 4498 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { ###### Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /g modifier is meaningless in split"); } 4498 if (!kid->op_sibling) 13 append_elem(OP_SPLIT, o, newDEFSVOP()); 4498 kid = kid->op_sibling; 4498 scalar(kid); 4498 if (!kid->op_sibling) 3994 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); 4498 kid = kid->op_sibling; 4498 scalar(kid); 4498 if (kid->op_sibling) ###### return too_many_arguments(o,OP_DESC(o)); 4498 return o; } OP * Perl_ck_join(pTHX_ OP *o) 11295 { 11295 if (ckWARN(WARN_SYNTAX)) { 663 const OP *kid = cLISTOPo->op_first->op_sibling; 663 if (kid && kid->op_type == OP_MATCH) { ###### const REGEXP *re = PM_GETRE(kPMOP); ###### const char *pmstr = re ? re->precomp : "STRING"; ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "/%s/ should probably be written as \"%s\"", pmstr, pmstr); } } 11295 return ck_fun(o); } OP * Perl_ck_subr(pTHX_ OP *o) 163081 { 163081 OP *prev = ((cUNOPo->op_first->op_sibling) 163081 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first; 163081 OP *o2 = prev->op_sibling; 163081 OP *cvop; 163081 char *proto = 0; 163081 CV *cv = 0; 163081 GV *namegv = 0; 163081 int optional = 0; 163081 I32 arg = 0; 163081 I32 contextclass = 0; 163081 char *e = 0; 163081 bool delete_op = 0; 163081 o->op_private |= OPpENTERSUB_HASTARG; 163081 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; 163081 if (cvop->op_type == OP_RV2CV) { 113417 SVOP* tmpop; 113417 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); 113417 op_null(cvop); /* disable rv2cv */ 113417 tmpop = (SVOP*)((UNOP*)cvop)->op_first; 113417 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) { 87656 GV *gv = cGVOPx_gv(tmpop); 87656 cv = GvCVu(gv); 87656 if (!cv) 30120 tmpop->op_private |= OPpEARLY_CV; else { 57536 if (SvPOK(cv)) { 2055 namegv = CvANON(cv) ? gv : CvGV(cv); 2055 proto = SvPV_nolen((SV*)cv); } 57536 if (CvASSERTION(cv)) { ###### if (PL_hints & HINT_ASSERTING) { ###### if (PERLDB_ASSERTION && PL_curstash != PL_debstash) ###### o->op_private |= OPpENTERSUB_DB; } else { ###### delete_op = 1; ###### if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) { ###### Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS), "Impossible to activate assertion call"); } } } } } } 49664 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) { 49664 if (o2->op_type == OP_CONST) 25891 o2->op_private &= ~OPpCONST_STRICT; 23773 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; } } 163081 o->op_private |= (PL_hints & HINT_STRICT_REFS); 163081 if (PERLDB_SUB && PL_curstash != PL_debstash) ###### o->op_private |= OPpENTERSUB_DB; 372066 while (o2 != cvop) { 208985 if (proto) { 3035 switch (*proto) { case '\0': ###### return too_many_arguments(o, gv_ename(namegv)); case ';': 150 optional = 1; 150 proto++; 150 continue; case '$': 1884 proto++; 1884 arg++; 1884 scalar(o2); 1884 break; case '%': case '@': 869 list(o2); 869 arg++; 869 break; case '&': 125 proto++; 125 arg++; 125 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF) ###### bad_type(arg, arg == 1 ? "block or sub {}" : "sub {}", gv_ename(namegv), o2); ###### break; case '*': /* '*' allows any scalar type, including bareword */ ###### proto++; ###### arg++; ###### if (o2->op_type == OP_RV2GV) ###### goto wrapref; /* autoconvert GLOB -> GLOBref */ ###### else if (o2->op_type == OP_CONST) ###### o2->op_private &= ~OPpCONST_STRICT; ###### else if (o2->op_type == OP_ENTERSUB) { /* accidental subroutine, revert to bareword */ ###### OP *gvop = ((UNOP*)o2)->op_first; ###### if (gvop && gvop->op_type == OP_NULL) { ###### gvop = ((UNOP*)gvop)->op_first; ###### if (gvop) { ###### for (; gvop->op_sibling; gvop = gvop->op_sibling) ; ###### if (gvop && (gvop->op_private & OPpENTERSUB_NOPAREN) && (gvop = ((UNOP*)gvop)->op_first) && gvop->op_type == OP_GV) { ###### GV *gv = cGVOPx_gv(gvop); ###### OP *sibling = o2->op_sibling; ###### SV *n = newSVpvn("",0); ###### op_free(o2); ###### gv_fullname4(n, gv, "", FALSE); ###### o2 = newSVOP(OP_CONST, 0, n); ###### prev->op_sibling = o2; ###### o2->op_sibling = sibling; } } } } ###### scalar(o2); ###### break; case '[': case ']': 7 goto oops; 7 break; case '\\': 7 proto++; 7 arg++; again: 7 switch (*proto++) { case '[': ###### if (contextclass++ == 0) { ###### e = strchr(proto, ']'); ###### if (!e || e == proto) ###### goto oops; } else ###### goto oops; ###### goto again; ###### break; case ']': ###### if (contextclass) { ###### char *p = proto; ###### const char s = *p; ###### contextclass = 0; ###### *p = '\0'; ###### while (*--p != '['); ###### bad_type(arg, Perl_form(aTHX_ "one of %s", p), gv_ename(namegv), o2); ###### *proto = s; } else ###### goto oops; ###### break; case '*': ###### if (o2->op_type == OP_RV2GV) ###### goto wrapref; ###### if (!contextclass) ###### bad_type(arg, "symbol", gv_ename(namegv), o2); ###### break; case '&': ###### if (o2->op_type == OP_ENTERSUB) ###### goto wrapref; ###### if (!contextclass) ###### bad_type(arg, "subroutine entry", gv_ename(namegv), o2); ###### break; case '$': ###### 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) ###### goto wrapref; ###### if (!contextclass) ###### bad_type(arg, "scalar", gv_ename(namegv), o2); ###### break; case '@': 7 if (o2->op_type == OP_RV2AV || o2->op_type == OP_PADAV) ###### goto wrapref; ###### if (!contextclass) ###### bad_type(arg, "array", gv_ename(namegv), o2); ###### break; case '%': ###### if (o2->op_type == OP_RV2HV || o2->op_type == OP_PADHV) ###### goto wrapref; ###### if (!contextclass) ###### bad_type(arg, "hash", gv_ename(namegv), o2); ###### break; wrapref: { 7 OP* kid = o2; 7 OP* sib = kid->op_sibling; 7 kid->op_sibling = 0; 7 o2 = newUNOP(OP_REFGEN, 0, kid); 7 o2->op_sibling = sib; 7 prev->op_sibling = o2; } 7 if (contextclass && e) { ###### proto = e + 1; ###### contextclass = 0; } break; 7 default: goto oops; } 7 if (contextclass) ###### goto again; ###### break; case ' ': ###### proto++; ###### continue; default: oops: ###### Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf, gv_ename(namegv), cv); } } else 205950 list(o2); 208835 mod(o2, OP_ENTERSUB); 208835 prev = o2; 208835 o2 = o2->op_sibling; } 163081 if (proto && !optional && (*proto && *proto != '@' && *proto != '%' && *proto != ';')) ###### return too_few_arguments(o, gv_ename(namegv)); 163081 if(delete_op) { ###### op_free(o); ###### o=newSVOP(OP_CONST, 0, newSViv(0)); } 163081 return o; } OP * Perl_ck_svconst(pTHX_ OP *o) 1705458 { 1705458 SvREADONLY_on(cSVOPo->op_sv); 1705458 return o; } OP * Perl_ck_trunc(pTHX_ OP *o) ###### { ###### if (o->op_flags & OPf_KIDS) { ###### SVOP *kid = (SVOP*)cUNOPo->op_first; ###### if (kid->op_type == OP_NULL) ###### kid = (SVOP*)kid->op_sibling; ###### if (kid && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { ###### o->op_flags |= OPf_SPECIAL; ###### kid->op_private &= ~OPpCONST_STRICT; } } ###### return ck_fun(o); } OP * Perl_ck_unpack(pTHX_ OP *o) 261 { 261 OP *kid = cLISTOPo->op_first; 261 if (kid->op_sibling) { 261 kid = kid->op_sibling; 261 if (!kid->op_sibling) ###### kid->op_sibling = newDEFSVOP(); } 261 return ck_fun(o); } OP * Perl_ck_substr(pTHX_ OP *o) 4856 { 4856 o = ck_fun(o); 4856 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) { ###### OP *kid = cLISTOPo->op_first; ###### if (kid->op_type == OP_NULL) ###### kid = kid->op_sibling; ###### if (kid) ###### kid->op_flags |= OPf_MOD; } 4856 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) 614813 { dVAR; 614813 register OP* oldop = 0; 614813 if (!o || o->op_opt) 464967 return; 464967 ENTER; 464967 SAVEOP(); 464967 SAVEVPTR(PL_curcop); 16263763 for (; o; o = o->op_next) { 8252267 if (o->op_opt) 352869 break; 7899398 PL_op = o; 7899398 switch (o->op_type) { case OP_SETSTATE: case OP_NEXTSTATE: case OP_DBSTATE: 774722 PL_curcop = ((COP*)o); /* for warnings */ 774722 o->op_opt = 1; 774722 break; case OP_CONST: 899697 if (cSVOPo->op_private & OPpCONST_STRICT) ###### 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 899697 o->op_opt = 1; 899697 break; case OP_CONCAT: 214692 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { 73678 if (o->op_next->op_private & OPpTARGET_MY) { 5346 if (o->op_flags & OPf_STACKED) /* chained concats */ 2305 goto ignore_optimization; else { /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ 3041 o->op_targ = o->op_next->op_targ; 3041 o->op_next->op_targ = 0; 3041 o->op_private |= OPpTARGET_MY; } } 71373 op_null(o->op_next); } ignore_optimization: 214692 o->op_opt = 1; 214692 break; case OP_STUB: 6165 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { 2665 o->op_opt = 1; 2665 break; /* Scalar stub must produce undef. List stub is noop */ } 1437660 goto nothin; case OP_NULL: 1437660 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE || o->op_targ == OP_SETSTATE) { 25066 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 */ 1437660 if (oldop && o->op_next) { 1433856 oldop->op_next = o->op_next; 1433856 continue; } 192374 break; case OP_SCALAR: case OP_LINESEQ: case OP_SCOPE: nothin: 192374 if (oldop && o->op_next) { 188939 oldop->op_next = o->op_next; 188939 continue; } 3435 o->op_opt = 1; 3435 break; case OP_PADAV: case OP_GV: 605899 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { 198855 OP* pop = (o->op_type == OP_PADAV) ? 198855 o->op_next : o->op_next->op_next; 198855 IV i; 198855 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) { 16039 GV *gv; 16039 if (cSVOPx(pop)->op_private & OPpCONST_STRICT) ###### no_bareword_allowed(pop); 16039 if (o->op_type == OP_GV) 9733 op_null(o->op_next); 16039 op_null(pop->op_next); 16039 op_null(pop); 16039 o->op_flags |= pop->op_next->op_flags & OPf_MOD; 16039 o->op_next = pop->op_next->op_next; 16039 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; 16039 o->op_private = (U8)i; 16039 if (o->op_type == OP_GV) { 9733 gv = cGVOPo_gv; 9733 GvAVn(gv); } else 6306 o->op_flags |= OPf_SPECIAL; 16039 o->op_type = OP_AELEMFAST; } 198855 o->op_opt = 1; 198855 break; } 407044 if (o->op_next->op_type == OP_RV2SV) { 216187 if (!(o->op_next->op_private & OPpDEREF)) { 215942 op_null(o->op_next); 215942 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO | OPpOUR_INTRO); 215942 o->op_next = o->op_next->op_next; 215942 o->op_type = OP_GVSV; 215942 o->op_ppaddr = PL_ppaddr[OP_GVSV]; } } 190857 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { 5587 GV *gv = cGVOPo_gv; 5587 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) { /* XXX could check prototype here instead of just carping */ ###### SV *sv = sv_newmortal(); ###### gv_efullname3(sv, gv, Nullch); ###### Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf"() called too early to check prototype", sv); } } 185270 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 */ ###### o->op_type = OP_RCATLINE; ###### o->op_flags |= OPf_STACKED; ###### o->op_ppaddr = PL_ppaddr[OP_RCATLINE]; ###### op_null(o->op_next->op_next); ###### op_null(o->op_next); } 407044 o->op_opt = 1; 407044 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: 352960 o->op_opt = 1; 398187 while (cLOGOP->op_other->op_type == OP_NULL) 45227 cLOGOP->op_other = cLOGOP->op_other->op_next; 352960 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ 352960 break; case OP_ENTERLOOP: case OP_ENTERITER: 30083 o->op_opt = 1; 30438 while (cLOOP->op_redoop->op_type == OP_NULL) 355 cLOOP->op_redoop = cLOOP->op_redoop->op_next; 30083 peep(cLOOP->op_redoop); 30083 while (cLOOP->op_nextop->op_type == OP_NULL) ###### cLOOP->op_nextop = cLOOP->op_nextop->op_next; 30083 peep(cLOOP->op_nextop); 30083 while (cLOOP->op_lastop->op_type == OP_NULL) ###### cLOOP->op_lastop = cLOOP->op_lastop->op_next; 30083 peep(cLOOP->op_lastop); 30083 break; case OP_QR: case OP_MATCH: case OP_SUBST: 65650 o->op_opt = 1; 66514 while (cPMOP->op_pmreplstart && cPMOP->op_pmreplstart->op_type == OP_NULL) 864 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next; 65650 peep(cPMOP->op_pmreplstart); 65650 break; case OP_EXEC: 191 o->op_opt = 1; 191 if (ckWARN(WARN_SYNTAX) && o->op_next && o->op_next->op_type == OP_NEXTSTATE) { ###### 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) { ###### const line_t oldline = CopLINE(PL_curcop); ###### CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next)); ###### Perl_warner(aTHX_ packWARN(WARN_EXEC), "Statement unlikely to be reached"); ###### Perl_warner(aTHX_ packWARN(WARN_EXEC), "\t(Maybe you meant system() when you said exec()?)\n"); ###### CopLINE_set(PL_curcop, oldline); } } ###### break; case OP_HELEM: { 100723 UNOP *rop; 100723 SV *lexname; 100723 GV **fields; 100723 SV **svp, *sv; 100723 const char *key = NULL; 100723 STRLEN keylen; 100723 o->op_opt = 1; 100723 if (((BINOP*)o)->op_last->op_type != OP_CONST) 35352 break; /* Make the CONST have a shared SV */ 65371 svp = cSVOPx_svp(((BINOP*)o)->op_last); 65371 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { 65371 key = SvPV_const(sv, keylen); 65371 lexname = newSVpvn_share(key, SvUTF8(sv) ? -(I32)keylen : keylen, 0); 65371 SvREFCNT_dec(sv); 65371 *svp = lexname; } 65371 if ((o->op_private & (OPpLVAL_INTRO))) 2962 break; 62409 rop = (UNOP*)((BINOP*)o)->op_first; 62409 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) 28996 break; 28996 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); 28996 if (!(SvFLAGS(lexname) & SVpad_TYPED)) 28996 break; ###### fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); ###### if (!fields || !GvHV(*fields)) ###### break; ###### key = SvPV_const(*svp, keylen); ###### if (!hv_fetch(GvHV(*fields), key, SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE)) { ###### Perl_croak(aTHX_ "No such class field \"%s\" " "in variable %s of type %s", key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname))); } 2765 break; } case OP_HSLICE: { 2765 UNOP *rop; 2765 SV *lexname; 2765 GV **fields; 2765 SV **svp; 2765 const char *key; 2765 STRLEN keylen; 2765 SVOP *first_key_op, *key_op; 2765 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. */ 1189 break; 1189 rop = (UNOP*)((LISTOP*)o)->op_last; 1189 if (rop->op_type != OP_RV2HV) 723 break; 466 if (rop->op_first->op_type == OP_PADSV) /* @$hash{qw(keys here)} */ 16 rop = (UNOP*)rop->op_first; else { /* @{$hash}{qw(keys here)} */ 450 if (rop->op_first->op_type == OP_SCOPE && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV) { 182 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last; } else 198 break; } 198 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE); 198 if (!(SvFLAGS(lexname) & SVpad_TYPED)) 198 break; ###### fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); ###### if (!fields || !GvHV(*fields)) ###### break; /* Again guessing that the pushmark can be jumped over.... */ ###### first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling) ->op_first->op_sibling; ###### for (key_op = first_key_op; key_op; key_op = (SVOP*)key_op->op_sibling) { ###### if (key_op->op_type != OP_CONST) ###### continue; ###### svp = cSVOPx_svp(key_op); ###### key = SvPV_const(*svp, keylen); ###### if (!hv_fetch(GvHV(*fields), key, SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE)) { ###### Perl_croak(aTHX_ "No such class field \"%s\" " "in variable %s of type %s", key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname))); } } 2933 break; } case OP_SORT: { /* will point to RV2AV or PADAV op on LHS/RHS of assign */ 2933 OP *oleft, *oright; 2933 OP *o2; /* check that RHS of sort is a single plain array */ 2933 oright = cUNOPo->op_first; 2933 if (!oright || oright->op_type != OP_PUSHMARK) 2933 break; /* reverse sort ... can be optimised. */ 2933 if (!cUNOPo->op_sibling) { /* Nothing follows us on the list. */ 2762 OP *reverse = o->op_next; 2762 if (reverse->op_type == OP_REVERSE && (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { 42 OP *pushmark = cUNOPx(reverse)->op_first; 42 if (pushmark && (pushmark->op_type == OP_PUSHMARK) && (cUNOPx(pushmark)->op_sibling == o)) { /* reverse -> pushmark -> sort */ 42 o->op_private |= OPpSORT_REVERSE; 42 op_null(reverse); 42 pushmark->op_next = oright->op_next; 42 op_null(oright); } } } /* make @a = sort @a act in-place */ 2933 o->op_opt = 1; 2933 oright = cUNOPx(oright)->op_sibling; 2933 if (!oright) ###### break; 2933 if (oright->op_type == OP_NULL) { /* skip sort block/sub */ 816 oright = cUNOPx(oright)->op_sibling; } 2933 if (!oright || (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV) || oright->op_next != o || (oright->op_private & OPpLVAL_INTRO) ) 340 break; /* o2 follows the chain of op_nexts through the LHS of the * assign (if any) to the aassign op itself */ 340 o2 = o->op_next; 340 if (!o2 || o2->op_type != OP_NULL) 111 break; 111 o2 = o2->op_next; 111 if (!o2 || o2->op_type != OP_PUSHMARK) 2 break; 2 o2 = o2->op_next; 2 if (o2 && o2->op_type == OP_GV) ###### o2 = o2->op_next; 2 if (!o2 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV) || (o2->op_private & OPpLVAL_INTRO) ) ###### break; ###### oleft = o2; ###### o2 = o2->op_next; ###### if (!o2 || o2->op_type != OP_NULL) ###### break; ###### o2 = o2->op_next; ###### if (!o2 || o2->op_type != OP_AASSIGN || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID) ###### break; /* check that the sort is the first arg on RHS of assign */ ###### o2 = cUNOPx(o2)->op_first; ###### if (!o2 || o2->op_type != OP_NULL) ###### break; ###### o2 = cUNOPx(o2)->op_first; ###### if (!o2 || o2->op_type != OP_PUSHMARK) ###### break; ###### if (o2->op_sibling != o) ###### break; /* check the array is the same on both sides */ ###### if (oleft->op_type == OP_RV2AV) { ###### 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) ) ###### break; } ###### else if (oright->op_type != OP_PADAV || oright->op_targ != oleft->op_targ ) ###### break; /* transfer MODishness etc from LHS arg to RHS arg */ ###### oright->op_flags = oleft->op_flags; ###### o->op_private |= OPpSORT_INPLACE; /* excise push->gv->rv2av->null->aassign */ ###### o2 = o->op_next->op_next; ###### op_null(o2); /* PUSHMARK */ ###### o2 = o2->op_next; ###### if (o2->op_type == OP_GV) { ###### op_null(o2); /* GV */ ###### o2 = o2->op_next; } ###### op_null(o2); /* RV2AV or PADAV */ ###### o2 = o2->op_next->op_next; ###### op_null(o2); /* AASSIGN */ ###### o->op_next = o2->op_next; ###### break; } case OP_REVERSE: { 410 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; 410 OP *gvop = NULL; 410 LISTOP *enter, *exlist; 410 o->op_opt = 1; 410 enter = (LISTOP *) o->op_next; 410 if (!enter) ###### break; 410 if (enter->op_type == OP_NULL) { 408 enter = (LISTOP *) enter->op_next; 408 if (!enter) ###### break; } /* for $a (...) will have OP_GV then OP_RV2GV here. for (...) just has an OP_GV. */ 410 if (enter->op_type == OP_GV) { ###### gvop = (OP *) enter; ###### enter = (LISTOP *) enter->op_next; ###### if (!enter) ###### break; ###### if (enter->op_type == OP_RV2GV) { ###### enter = (LISTOP *) enter->op_next; ###### if (!enter) ###### break; } } 410 if (enter->op_type != OP_ENTERITER) 410 break; ###### iter = enter->op_next; ###### if (!iter || iter->op_type != OP_ITER) ###### break; ###### expushmark = enter->op_first; ###### if (!expushmark || expushmark->op_type != OP_NULL || expushmark->op_targ != OP_PUSHMARK) ###### break; ###### exlist = (LISTOP *) expushmark->op_sibling; ###### if (!exlist || exlist->op_type != OP_NULL || exlist->op_targ != OP_LIST) ###### break; ###### if (exlist->op_last != o) { /* Mmm. Was expecting to point back to this op. */ ###### break; } ###### theirmark = exlist->op_first; ###### if (!theirmark || theirmark->op_type != OP_PUSHMARK) ###### break; ###### if (theirmark->op_sibling != o) { /* There's something between the mark and the reverse, eg for (1, reverse (...)) so no go. */ ###### break; } ###### ourmark = ((LISTOP *)o)->op_first; ###### if (!ourmark || ourmark->op_type != OP_PUSHMARK) ###### break; ###### ourlast = ((LISTOP *)o)->op_last; ###### if (!ourlast || ourlast->op_next != o) ###### break; ###### rv2av = ourmark->op_sibling; ###### 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. */ ###### rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF; ###### enter->op_flags |= OPf_STACKED; } /* We don't have control over who points to theirmark, so sacrifice ours. */ ###### theirmark->op_next = ourmark->op_next; ###### theirmark->op_flags = ourmark->op_flags; ###### ourlast->op_next = gvop ? gvop : (OP *) enter; ###### op_null(ourmark); ###### op_null(o); ###### enter->op_private |= OPpITER_REVERSED; ###### iter->op_private |= OPpITER_REVERSED; ###### break; } default: 3215974 o->op_opt = 1; 6276603 break; } 6276603 oldop = o; } 464967 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) 769 { 769 dXSARGS; 769 if (items != 0) { #if 0 Perl_croak(aTHX_ "usage: %s::%s()", HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); #endif } 769 EXTEND(sp, 1); 769 ST(0) = (SV*)XSANY.any_ptr; 769 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: */