/* op.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was * our Mr. Bilbo's first cousin on the mother's side (her mother being the * youngest of the Old Took's daughters); and Mr. Drogo was his second * cousin. So Mr. Frodo is his first *and* second cousin, once removed * either way, as the saying is, if you follow me." --the Gaffer */ /* This file contains the functions that create, manipulate and optimize * the OP structures that hold a compiled perl program. * * A Perl program is compiled into a tree of OPs. Each op contains * structural pointers (eg to its siblings and the next op in the * execution sequence), a pointer to the function that would execute the * op, plus any data specific to that op. For example, an OP_CONST op * points to the pp_const() function and to an SV containing the constant * value. When pp_const() is executed, its job is to push that SV onto the * stack. * * OPs are mainly created by the newFOO() functions, which are mainly * called from the parser (in perly.y) as the code is parsed. For example * the Perl code $a + $b * $c would cause the equivalent of the following * to be called (oversimplifying a bit): * * newBINOP(OP_ADD, flags, * newSVREF($a), * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c)) * ) * * Note that during the build of miniperl, a temporary copy of this file * is made, called opmini.c. */ /* Perl's compiler is essentially a 3-pass compiler with interleaved phases: A bottom-up pass A top-down pass An execution-order pass The bottom-up pass is represented by all the "newOP" routines and the ck_ routines. The bottom-upness is actually driven by yacc. So at the point that a ck_ routine fires, we have no idea what the context is, either upward in the syntax tree, or either forward or backward in the execution order. (The bottom-up parser builds that part of the execution order it knows about, but if you follow the "next" links around, you'll find it's actually a closed loop through the top level node. Whenever the bottom-up parser gets to a node that supplies context to its components, it invokes that portion of the top-down pass that applies to that part of the subtree (and marks the top node as processed, so if a node further up supplies context, it doesn't have to take the plunge again). As a particular subcase of this, as the new node is built, it takes all the closed execution loops of its subcomponents and links them into a new closed loop for the higher level node. But it's still not the real execution order. The actual execution order is not known till we get a grammar reduction to a top-level unit like a subroutine or file that will be called by "name" rather than via a "next" pointer. At that point, we can call into peep() to do that code's portion of the 3rd pass. It has to be recursive, but it's recursive on basic blocks, not on tree nodes. */ #include "EXTERN.h" #define PERL_IN_OP_C #include "perl.h" #include "keywords.h" #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) #if defined(PL_OP_SLAB_ALLOC) #ifndef PERL_SLAB_SIZE #define PERL_SLAB_SIZE 2048 #endif void * Perl_Slab_Alloc(pTHX_ int m, size_t sz) { /* * To make incrementing use count easy PL_OpSlab is an I32 * * To make inserting the link to slab PL_OpPtr is I32 ** * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments * Add an overhead for pointer to slab and round up as a number of pointers */ sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *); if ((PL_OpSpace -= sz) < 0) { PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*)); if (!PL_OpPtr) { return NULL; } Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **); /* We reserve the 0'th I32 sized chunk as a use count */ PL_OpSlab = (I32 *) PL_OpPtr; /* Reduce size by the use count word, and by the size we need. * Latter is to mimic the '-=' in the if() above */ PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz; /* Allocation pointer starts at the top. Theory: because we build leaves before trunk allocating at end means that at run time access is cache friendly upward */ PL_OpPtr += PERL_SLAB_SIZE; } assert( PL_OpSpace >= 0 ); /* Move the allocation pointer down */ PL_OpPtr -= sz; assert( PL_OpPtr > (I32 **) PL_OpSlab ); *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */ (*PL_OpSlab)++; /* Increment use count of slab */ assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) ); assert( *PL_OpSlab > 0 ); return (void *)(PL_OpPtr + 1); } void Perl_Slab_Free(pTHX_ void *op) { I32 **ptr = (I32 **) op; I32 *slab = ptr[-1]; assert( ptr-1 > (I32 **) slab ); assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); assert( *slab > 0 ); if (--(*slab) == 0) { # ifdef NETWARE # define PerlMemShared PerlMem # endif PerlMemShared_free(slab); if (slab == PL_OpSlab) { PL_OpSpace = 0; } } } #endif /* * In the following definition, the ", Nullop" is just to make the compiler * think the expression is of the right type: croak actually does a Siglongjmp. */ #define CHECKOP(type,o) \ ((PL_op_mask && PL_op_mask[type]) \ ? ( op_free((OP*)o), \ Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ Nullop ) \ : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) STATIC const char* S_gv_ename(pTHX_ GV *gv) 24 { 24 SV* tmpsv = sv_newmortal(); 24 gv_efullname3(tmpsv, gv, Nullch); 24 return SvPV_nolen_const(tmpsv); } STATIC OP * S_no_fh_allowed(pTHX_ OP *o) ###### { ###### yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function", OP_DESC(o))); ###### return o; } STATIC OP * S_too_few_arguments(pTHX_ OP *o, const char *name) 16 { 16 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name)); 16 return o; } STATIC OP * S_too_many_arguments(pTHX_ OP *o, const char *name) 6 { 6 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name)); 6 return o; } STATIC void S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid) 7 { 7 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", (int)n, name, t, OP_DESC(kid))); } STATIC void S_no_bareword_allowed(pTHX_ const OP *o) 61 { 61 qerror(Perl_mess(aTHX_ "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", cSVOPo_sv)); } /* "register" allocation */ PADOFFSET Perl_allocmy(pTHX_ char *name) 635090 { 635090 PADOFFSET off; /* complain about "my $" etc etc */ 635090 if (!(PL_in_my == KEY_our || isALPHA(name[1]) || (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) || (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2)))) { 2 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { /* 1999-02-27 mjd@plover.com */ 2 char *p; 2 p = strchr(name, '\0'); /* The next block assumes the buffer is at least 205 chars long. At present, it's always at least 256 chars. */ 2 if (p-name > 200) { ###### strcpy(name+200, "..."); ###### p = name+199; } else { 2 p[1] = '\0'; } /* Move everything else down one character */ 6 for (; p-name > 2; p--) 2 *p = *(p-1); 2 name[2] = toCTRL(name[1]); 2 name[1] = '^'; } 2 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name)); } /* check for duplicate declaration */ 635090 pad_check_dup(name, (bool)(PL_in_my == KEY_our), (PL_curstash ? PL_curstash : PL_defstash) ); 635090 if (PL_in_my_stash && *name != '$') { 1 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"", name, PL_in_my == KEY_our ? "our" : "my")); } /* allocate a spare slot and store the name in that slot */ 635090 off = pad_add_name(name, PL_in_my_stash, (PL_in_my == KEY_our /* $_ is always in main::, even with our */ ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) : Nullhv ), 0 /* not fake */ ); 635090 return off; } /* Destructor */ void Perl_op_free(pTHX_ OP *o) 25397547 { dVAR; 25397547 OPCODE type; 25397547 PADOFFSET refcnt; 25397547 if (!o || o->op_static) 25355803 return; 25355803 if (o->op_private & OPpREFCOUNTED) { 1728901 switch (o->op_type) { case OP_LEAVESUB: case OP_LEAVESUBLV: case OP_LEAVEEVAL: case OP_LEAVE: case OP_SCOPE: case OP_LEAVEWRITE: 366706 OP_REFCNT_LOCK; 366706 refcnt = OpREFCNT_dec(o); 366706 OP_REFCNT_UNLOCK; 366706 if (refcnt) 12516 return; 25343287 break; default: 25343287 break; } } 25343287 if (o->op_flags & OPf_KIDS) { 11234144 register OP *kid, *nextkid; 34846211 for (kid = cUNOPo->op_first; kid; kid = nextkid) { 23612067 nextkid = kid->op_sibling; /* Get before next freeing kid */ 23612067 op_free(kid); } } 25343287 type = o->op_type; 25343287 if (type == OP_NULL) 3935573 type = (OPCODE)o->op_targ; /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ 25343287 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) 2388025 cop_free((COP*)o); 25343287 op_clear(o); 25343287 FreeOp(o); #ifdef DEBUG_LEAKING_SCALARS if (PL_op == o) PL_op = Nullop; #endif } void Perl_op_clear(pTHX_ OP *o) 28359880 { dVAR; 28359880 switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ case OP_ENTEREVAL: /* Was holding hints. */ 3951762 o->op_targ = 0; 3951762 break; default: 18371238 if (!(o->op_flags & OPf_REF) || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst))) 1456277 break; /* FALL THROUGH */ case OP_GVSV: case OP_GV: case OP_AELEMFAST: 1456277 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) { /* not an OP_PADAV replacement */ #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { /* No GvIN_PAD_off(cGVOPo_gv) here, because other references * may still exist on the pad */ pad_swipe(cPADOPo->op_padix, TRUE); cPADOPo->op_padix = 0; } #else 1440787 SvREFCNT_dec(cSVOPo->op_sv); 1440787 cSVOPo->op_sv = Nullsv; #endif } 1440787 break; case OP_METHOD_NAMED: case OP_CONST: 4357772 SvREFCNT_dec(cSVOPo->op_sv); 4357772 cSVOPo->op_sv = Nullsv; #ifdef USE_ITHREADS /** Bug #15654 Even if op_clear does a pad_free for the target of the op, pad_free doesn't actually remove the sv that exists in the pad; instead it lives on. This results in that it could be reused as a target later on when the pad was reallocated. **/ if(o->op_targ) { pad_swipe(o->op_targ,1); o->op_targ = 0; } #endif 4357772 break; case OP_GOTO: case OP_NEXT: case OP_LAST: case OP_REDO: 60131 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) 51862 break; /* FALL THROUGH */ case OP_TRANS: 13413 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { 47 SvREFCNT_dec(cSVOPo->op_sv); 47 cSVOPo->op_sv = Nullsv; } else { 13366 Safefree(cPVOPo->op_pv); 13366 cPVOPo->op_pv = Nullch; } 13366 break; case OP_SUBST: 53389 op_free(cPMOPo->op_pmreplroot); 53389 goto clear_pmop; case OP_PUSHRE: #ifdef USE_ITHREADS if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) { /* No GvIN_PAD_off here, because other references may still * exist on the pad */ pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE); } #else 8472 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot); #endif /* FALL THROUGH */ case OP_MATCH: case OP_QR: clear_pmop: { 160789 HV *pmstash = PmopSTASH(cPMOPo); 160789 if (pmstash && SvREFCNT(pmstash)) { 149836 MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); 149836 if (mg) { 149836 PMOP *pmop = (PMOP*) mg->mg_obj; 149836 PMOP *lastpmop = NULL; 1444779 while (pmop) { 1444779 if (cPMOPo == pmop) { 149836 if (lastpmop) 111331 lastpmop->op_pmnext = pmop->op_pmnext; else 38505 mg->mg_obj = (SV*) pmop->op_pmnext; 38505 break; } 1294943 lastpmop = pmop; 1294943 pmop = pmop->op_pmnext; } } } PmopSTASH_free(cPMOPo); } 160789 cPMOPo->op_pmreplroot = Nullop; /* we use the "SAFE" version of the PM_ macros here * since sv_clean_all might release some PMOPs * after PL_regex_padav has been cleared * and the clearing of PL_regex_padav needs to * happen before sv_clean_all */ 160789 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo)); 160789 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL); #ifdef USE_ITHREADS if(PL_regex_pad) { /* We could be in destruction */ av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]); SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]); PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset); } #endif 28359880 break; } 28359880 if (o->op_targ > 0) { 5851428 pad_free(o->op_targ); 5851428 o->op_targ = 0; } } STATIC void S_cop_free(pTHX_ COP* cop) 2388025 { 2388025 Safefree(cop->cop_label); /* FIXME: treaddead ??? */ 2388025 CopFILE_free(cop); CopSTASH_free(cop); 2388025 if (! specialWARN(cop->cop_warnings)) 34807 SvREFCNT_dec(cop->cop_warnings); 2388025 if (! specialCopIO(cop->cop_io)) { #ifdef USE_ITHREADS #if 0 STRLEN len; char *s = SvPV(cop->cop_io,len); Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */ #endif #else 26 SvREFCNT_dec(cop->cop_io); #endif } } void Perl_op_null(pTHX_ OP *o) 3016634 { dVAR; 3016634 if (o->op_type == OP_NULL) 41 return; 3016593 op_clear(o); 3016593 o->op_targ = o->op_type; 3016593 o->op_type = OP_NULL; 3016593 o->op_ppaddr = PL_ppaddr[OP_NULL]; } void Perl_op_refcnt_lock(pTHX) ###### { dVAR; ###### OP_REFCNT_LOCK; } void Perl_op_refcnt_unlock(pTHX) ###### { dVAR; ###### OP_REFCNT_UNLOCK; } /* Contextualizers */ #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) OP * Perl_linklist(pTHX_ OP *o) 9806890 { 9806890 if (o->op_next) 17335 return o->op_next; /* establish postfix order */ 9789555 if (cUNOPo->op_first) { 9758927 register OP *kid; 9758927 o->op_next = LINKLIST(cUNOPo->op_first); 30837684 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 21078757 if (kid->op_sibling) 11319830 kid->op_next = LINKLIST(kid->op_sibling); else 9758927 kid->op_next = o; } } else 30628 o->op_next = o; 9789555 return o->op_next; } OP * Perl_scalarkids(pTHX_ OP *o) 3934 { 3934 if (o && o->op_flags & OPf_KIDS) { 3934 OP *kid; 7868 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 3934 scalar(kid); } 3934 return o; } STATIC OP * S_scalarboolean(pTHX_ OP *o) 838502 { 838502 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { 4 if (ckWARN(WARN_SYNTAX)) { 1 const line_t oldline = CopLINE(PL_curcop); 1 if (PL_copline != NOLINE) 1 CopLINE_set(PL_curcop, PL_copline); 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); 1 CopLINE_set(PL_curcop, oldline); } } 838502 return scalar(o); } OP * Perl_scalar(pTHX_ OP *o) 35092526 { dVAR; 35092526 OP *kid; /* assumes no premature commitment */ 35092526 if (!o || (o->op_flags & OPf_WANT) || PL_error_count || o->op_type == OP_RETURN) { 18361743 return o; } 16730783 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; 16730783 switch (o->op_type) { case OP_REPEAT: 3344 scalar(cBINOPo->op_first); 3344 break; case OP_OR: case OP_AND: case OP_COND_EXPR: 434216 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 239298 scalar(kid); 7 break; case OP_SPLIT: 7 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { 7 if (!kPMOP->op_pmreplroot) 6 deprecate_old("implicit split to @_"); } /* FALL THROUGH */ case OP_MATCH: case OP_QR: case OP_SUBST: case OP_NULL: default: 16296827 if (o->op_flags & OPf_KIDS) { 15758785 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 9816246 scalar(kid); } 11485 break; case OP_LEAVE: case OP_LEAVETRY: 11485 kid = cLISTOPo->op_first; 11485 scalar(kid); 43007 while ((kid = kid->op_sibling)) { 31522 if (kid->op_sibling) 20037 scalarvoid(kid); else 11485 scalar(kid); } 11485 WITH_THR(PL_curcop = &PL_compiling); 11485 break; case OP_SCOPE: case OP_LINESEQ: case OP_LIST: 1246987 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 1022782 if (kid->op_sibling) 798577 scalarvoid(kid); else 224205 scalar(kid); } 224205 WITH_THR(PL_curcop = &PL_compiling); 224205 break; case OP_SORT: 4 if (ckWARN(WARN_VOID)) 1 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); } 16730783 return o; } OP * Perl_scalarvoid(pTHX_ OP *o) 9869337 { dVAR; 9869337 OP *kid; 9869337 const char* useless = 0; 9869337 SV* sv; 9869337 U8 want; 9869337 if (o->op_type == OP_NEXTSTATE || o->op_type == OP_SETSTATE || o->op_type == OP_DBSTATE || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_SETSTATE || o->op_targ == OP_DBSTATE))) 4637165 PL_curcop = (COP*)o; /* for warning below */ /* assumes no premature commitment */ 9869337 want = o->op_flags & OPf_WANT; 9869337 if ((want && want != OPf_WANT_SCALAR) || PL_error_count || o->op_type == OP_RETURN) { 3876459 return o; } 5992878 if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { 32885 return scalar(o); /* As if inside SASSIGN */ } 5959993 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 5959993 switch (o->op_type) { default: 1406876 if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) 1342523 break; /* FALL THROUGH */ case OP_REPEAT: 64362 if (o->op_flags & OPf_STACKED) 64273 break; 121 goto func_ops; case OP_SUBSTR: 121 if (o->op_private == 4) 118 break; /* FALL THROUGH */ case OP_GVSV: case OP_WANTARRAY: case OP_GV: case OP_PADSV: case OP_PADAV: case OP_PADHV: case OP_PADANY: case OP_AV2ARYLEN: case OP_REF: case OP_REFGEN: case OP_SREFGEN: case OP_DEFINED: case OP_HEX: case OP_OCT: case OP_LENGTH: case OP_VEC: case OP_INDEX: case OP_RINDEX: case OP_SPRINTF: case OP_AELEM: case OP_AELEMFAST: case OP_ASLICE: case OP_HELEM: case OP_HSLICE: case OP_UNPACK: case OP_PACK: case OP_JOIN: case OP_LSLICE: case OP_ANONLIST: case OP_ANONHASH: case OP_SORT: case OP_REVERSE: case OP_RANGE: case OP_FLIP: case OP_FLOP: case OP_CALLER: case OP_FILENO: case OP_EOF: case OP_TELL: case OP_GETSOCKNAME: case OP_GETPEERNAME: case OP_READLINK: case OP_TELLDIR: case OP_GETPPID: case OP_GETPGRP: case OP_GETPRIORITY: case OP_TIME: case OP_TMS: case OP_LOCALTIME: case OP_GMTIME: case OP_GHBYNAME: case OP_GHBYADDR: case OP_GHOSTENT: case OP_GNBYNAME: case OP_GNBYADDR: case OP_GNETENT: case OP_GPBYNAME: case OP_GPBYNUMBER: case OP_GPROTOENT: case OP_GSBYNAME: case OP_GSBYPORT: case OP_GSERVENT: case OP_GPWNAM: case OP_GPWUID: case OP_GGRNAM: case OP_GGRGID: case OP_GETLOGIN: case OP_PROTOTYPE: func_ops: 98206 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) 286 useless = OP_DESC(o); 286 break; case OP_NOT: 1 kid = cUNOPo->op_first; 1 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && kid->op_type != OP_TRANS) { 1 goto func_ops; } ###### useless = "negative pattern binding (!~)"; ###### break; case OP_RV2GV: case OP_RV2SV: case OP_RV2AV: case OP_RV2HV: 33354 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) 23 useless = "a variable"; 23 break; case OP_CONST: 3579 sv = cSVOPo_sv; 3579 if (cSVOPo->op_private & OPpCONST_STRICT) 3 no_bareword_allowed(o); else { 3576 if (ckWARN(WARN_VOID)) { 2076 useless = "a constant"; /* don't warn on optimised away booleans, eg * use constant Foo, 5; Foo || print; */ 2076 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) 1798 useless = 0; /* the constants 0 and 1 are permitted as they are conventionally used as dummies in constructs like 1 while some_condition_with_side_effects; */ 278 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) 276 useless = 0; 2 else if (SvPOK(sv)) { /* perl4's way of mixing documentation and code (before the invention of POD) was based on a trick to mix nroff and perl code. The trick was built upon these three nroff macros being used in void context. The pink camel has the details in the script wrapman near page 319. */ 1 if (strnEQ(SvPVX_const(sv), "di", 2) || strnEQ(SvPVX_const(sv), "ds", 2) || strnEQ(SvPVX_const(sv), "ig", 2)) ###### useless = 0; } } } 3579 op_null(o); /* don't execute or even remember it */ 3579 break; case OP_POSTINC: 13447 o->op_type = OP_PREINC; /* pre-increment is faster */ 13447 o->op_ppaddr = PL_ppaddr[OP_PREINC]; 13447 break; case OP_POSTDEC: 1222 o->op_type = OP_PREDEC; /* pre-decrement is faster */ 1222 o->op_ppaddr = PL_ppaddr[OP_PREDEC]; 1222 break; case OP_OR: case OP_AND: case OP_DOR: case OP_COND_EXPR: 1235379 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 673645 scalarvoid(kid); 580709 break; case OP_NULL: 580709 if (o->op_flags & OPf_STACKED) 3461 break; /* FALL THROUGH */ case OP_NEXTSTATE: case OP_DBSTATE: case OP_ENTERTRY: case OP_ENTER: 3162015 if (!(o->op_flags & OPf_KIDS)) 2585077 break; /* FALL THROUGH */ case OP_SCOPE: case OP_LEAVE: case OP_LEAVETRY: case OP_LEAVELOOP: case OP_LINESEQ: case OP_LIST: 3929768 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 2839883 scalarvoid(kid); 3934 break; case OP_ENTEREVAL: 3934 scalarkids(o); 3934 break; case OP_REQUIRE: /* all requires must return a boolean value */ 159090 o->op_flags &= ~OPf_WANT; /* FALL THROUGH */ case OP_SCALAR: 159095 return scalar(o); case OP_SPLIT: 81 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { 81 if (!kPMOP->op_pmreplroot) 9 deprecate_old("implicit split to @_"); } 5800894 break; } 5800894 if (useless && ckWARN(WARN_VOID)) 80 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless); 5800891 return o; } OP * Perl_listkids(pTHX_ OP *o) 2808023 { 2808023 if (o && o->op_flags & OPf_KIDS) { 2808023 OP *kid; 9062762 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 6254739 list(kid); } 2808023 return o; } OP * Perl_list(pTHX_ OP *o) 7761601 { dVAR; 7761601 OP *kid; /* assumes no premature commitment */ 7761601 if (!o || (o->op_flags & OPf_WANT) || PL_error_count || o->op_type == OP_RETURN) { 5736022 return o; } 2025579 if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { ###### return o; /* As if inside SASSIGN */ } 2025579 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; 2025579 switch (o->op_type) { case OP_FLOP: case OP_REPEAT: 5549 list(cBINOPo->op_first); 5549 break; case OP_OR: case OP_AND: case OP_COND_EXPR: 52114 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 33927 list(kid); 1967855 break; default: case OP_MATCH: case OP_QR: case OP_SUBST: case OP_NULL: 1967855 if (!(o->op_flags & OPf_KIDS)) 675202 break; 1292653 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) { 1028 list(cBINOPo->op_first); 1028 return gen_constant_list(o); } case OP_LIST: 1315409 listkids(o); 1315409 break; case OP_LEAVE: case OP_LEAVETRY: 4373 kid = cLISTOPo->op_first; 4373 list(kid); 15946 while ((kid = kid->op_sibling)) { 11573 if (kid->op_sibling) 7200 scalarvoid(kid); else 4373 list(kid); } 4373 WITH_THR(PL_curcop = &PL_compiling); 4373 break; case OP_SCOPE: case OP_LINESEQ: 17495 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 11665 if (kid->op_sibling) 5835 scalarvoid(kid); else 5830 list(kid); } 5830 WITH_THR(PL_curcop = &PL_compiling); 5830 break; case OP_REQUIRE: /* all requires must return a boolean value */ 1 o->op_flags &= ~OPf_WANT; 1 return scalar(o); } 2024550 return o; } OP * Perl_scalarseq(pTHX_ OP *o) 1339510 { 1339510 if (o) { 1332461 if (o->op_type == OP_LINESEQ || o->op_type == OP_SCOPE || o->op_type == OP_LEAVE || o->op_type == OP_LEAVETRY) { 1124644 OP *kid; 7757236 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 6632595 if (kid->op_sibling) { 5507954 scalarvoid(kid); } } 1124641 PL_curcop = &PL_compiling; } 1332458 o->op_flags &= ~OPf_PARENS; 1332458 if (PL_hints & HINT_BLOCK_SCOPE) 1003351 o->op_flags |= OPf_PARENS; } else 7049 o = newOP(OP_STUB, 0); 1339507 return o; } STATIC OP * S_modkids(pTHX_ OP *o, I32 type) 306638 { 306638 if (o && o->op_flags & OPf_KIDS) { 279746 OP *kid; 559492 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 279746 mod(kid, type); } 306638 return o; } /* Propagate lvalue ("modifiable") context to an op and it's children. * 'type' represents the context type, roughly based on the type of op that * would do the modifying, although local() is represented by OP_NULL. * It's responsible for detecting things that can't be modified, flag * things that need to behave specially in an lvalue context (e.g., "$$x = 5" * might have to vivify a reference in $x), and so on. * * For example, "$a+1 = 2" would cause mod() to be called with o being * OP_ADD and type being OP_SASSIGN, and would output an error. */ OP * Perl_mod(pTHX_ OP *o, I32 type) 3468262 { dVAR; 3468262 OP *kid; /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ 3468262 int localize = -1; 3468262 if (!o || PL_error_count) 1385 return o; 3466877 if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { 70 return o; } 3466807 switch (o->op_type) { case OP_UNDEF: 3908 localize = 0; 3908 PL_modcount++; 3908 return o; case OP_CONST: 360069 if (!(o->op_private & (OPpCONST_ARYBASE))) 360050 goto nomod; 19 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { 14 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv); 14 PL_eval_start = 0; } 5 else if (!type) { 2 SAVEI32(PL_compiling.cop_arybase); 2 PL_compiling.cop_arybase = 0; } 3 else if (type == OP_REFGEN) ###### goto nomod; else 3 Perl_croak(aTHX_ "That use of $[ is unsupported"); 2062 break; case OP_STUB: 2062 if (o->op_flags & OPf_PARENS) 2062 break; 77895 goto nomod; case OP_ENTERSUB: 77895 if ((type == OP_UNDEF || type == OP_REFGEN) && !(o->op_flags & OPf_STACKED)) { 46193 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 46193 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 46193 assert(cUNOPo->op_first->op_type == OP_NULL); 46193 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ 46193 break; } 31702 else if (o->op_private & OPpENTERSUB_NOMOD) 1 return o; else { /* lvalue subroutine call */ 31701 o->op_private |= OPpLVAL_INTRO; 31701 PL_modcount = RETURN_UNLIMITED_NUMBER; 31701 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { /* Backward compatibility mode: */ 31632 o->op_private |= OPpENTERSUB_INARGS; 31632 break; } else { /* Compile-time error message: */ 69 OP *kid = cUNOPo->op_first; 69 CV *cv; 69 OP *okid; 69 if (kid->op_type == OP_PUSHMARK) 4 goto skip_kids; 65 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) ###### Perl_croak(aTHX_ "panic: unexpected lvalue entersub " "args: type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); 65 kid = kLISTOP->op_first; skip_kids: 161 while (kid->op_sibling) 92 kid = kid->op_sibling; 69 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { /* Indirect call */ 4 if (kid->op_type == OP_METHOD_NAMED || kid->op_type == OP_METHOD) { 4 UNOP *newop; 4 NewOp(1101, newop, 1, UNOP); 4 newop->op_type = OP_RV2CV; 4 newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; 4 newop->op_first = Nullop; 4 newop->op_next = (OP*)newop; 4 kid->op_sibling = (OP*)newop; 4 newop->op_private |= OPpLVAL_INTRO; 4 break; } ###### if (kid->op_type != OP_RV2CV) ###### Perl_croak(aTHX_ "panic: unexpected lvalue entersub " "entry via type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); ###### kid->op_private |= OPpLVAL_INTRO; ###### break; /* Postpone until runtime */ } 65 okid = kid; 65 kid = kUNOP->op_first; 65 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) ###### kid = kUNOP->op_first; 65 if (kid->op_type == OP_NULL) ###### Perl_croak(aTHX_ "Unexpected constant lvalue entersub " "entry via type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); 65 if (kid->op_type != OP_GV) { /* Restore RV2CV to check lvalueness */ restore_2cv: 4 if (kid->op_next && kid->op_next != kid) { /* Happens? */ ###### okid->op_next = kid->op_next; ###### kid->op_next = okid; } else 4 okid->op_next = Nullop; 4 okid->op_type = OP_RV2CV; 4 okid->op_targ = 0; 4 okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; 4 okid->op_private |= OPpLVAL_INTRO; 4 break; } 62 cv = GvCV(kGVOP_gv); 62 if (!cv) 1 goto restore_2cv; 61 if (CvLVALUE(cv)) 57 break; } } /* FALL THROUGH */ default: nomod: /* grep, foreach, subcalls, refgen */ 630442 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) 28 break; 28 yyerror(Perl_form(aTHX_ "Can't modify %s in %s", (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) ? "do block" : (o->op_type == OP_ENTERSUB ? "non-lvalue subroutine call" : OP_DESC(o))), type ? PL_op_desc[type] : "local")); 28 return o; case OP_PREINC: case OP_PREDEC: case OP_POW: case OP_MULTIPLY: case OP_DIVIDE: case OP_MODULO: case OP_REPEAT: case OP_ADD: case OP_SUBTRACT: case OP_CONCAT: case OP_LEFT_SHIFT: case OP_RIGHT_SHIFT: case OP_BIT_AND: case OP_BIT_XOR: case OP_BIT_OR: case OP_I_MULTIPLY: case OP_I_DIVIDE: case OP_I_MODULO: case OP_I_ADD: case OP_I_SUBTRACT: 9252 if (!(o->op_flags & OPf_STACKED)) 7521 goto nomod; 1731 PL_modcount++; 1731 break; case OP_COND_EXPR: 4967 localize = 1; 14901 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 9934 mod(kid, type); 334273 break; case OP_RV2AV: case OP_RV2HV: 334273 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { 34 PL_modcount = RETURN_UNLIMITED_NUMBER; 34 return o; /* Treat \(@foo) like ordinary list. */ } /* FALL THROUGH */ case OP_RV2GV: 375818 if (scalar_mod_type(o, type)) 1 goto nomod; 375817 ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_ASLICE: case OP_HSLICE: 383996 if (type == OP_LEAVESUBLV) 6 o->op_private |= OPpMAYBE_LVSUB; 383996 localize = 1; /* FALL THROUGH */ case OP_AASSIGN: case OP_NEXTSTATE: case OP_DBSTATE: 384078 PL_modcount = RETURN_UNLIMITED_NUMBER; 384078 break; case OP_RV2SV: 267244 ref(cUNOPo->op_first, o->op_type); 267244 localize = 1; /* FALL THROUGH */ case OP_GV: case OP_AV2ARYLEN: 268025 PL_hints |= HINT_BLOCK_SCOPE; case OP_SASSIGN: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: 272844 PL_modcount++; 272844 break; case OP_AELEMFAST: ###### localize = -1; ###### PL_modcount++; ###### break; case OP_PADAV: case OP_PADHV: 132972 PL_modcount = RETURN_UNLIMITED_NUMBER; 132972 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) 4 return o; /* Treat \(@foo) like ordinary list. */ 132968 if (scalar_mod_type(o, type)) 1 goto nomod; 132967 if (type == OP_LEAVESUBLV) 3 o->op_private |= OPpMAYBE_LVSUB; /* FALL THROUGH */ case OP_PADSV: 1317582 PL_modcount++; 1317582 if (!type) /* local() */ 1 Perl_croak(aTHX_ "Can't localize lexical variable %s", PAD_COMPNAME_PV(o->op_targ)); 292295 break; case OP_PUSHMARK: 292295 localize = 0; 292295 break; case OP_KEYS: 5519 if (type != OP_SASSIGN) 5515 goto nomod; 1605 goto lvalue_func; case OP_SUBSTR: 1605 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ 8 goto nomod; /* FALL THROUGH */ case OP_POS: case OP_VEC: 10070 if (type == OP_LEAVESUBLV) 4 o->op_private |= OPpMAYBE_LVSUB; lvalue_func: 10074 pad_free(o->op_targ); 10074 o->op_targ = pad_alloc(o->op_type, SVs_PADMY); 10074 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL); 10074 if (o->op_flags & OPf_KIDS) 10074 mod(cBINOPo->op_first->op_sibling, type); 10074 break; case OP_AELEM: case OP_HELEM: 169902 ref(cBINOPo->op_first, o->op_type); 169902 if (type == OP_ENTERSUB && !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) 41682 o->op_private |= OPpLVAL_DEFER; 169902 if (type == OP_LEAVESUBLV) 8 o->op_private |= OPpMAYBE_LVSUB; 169902 localize = 1; 169902 PL_modcount++; 169902 break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: case OP_LINESEQ: 47 localize = 0; 47 if (o->op_flags & OPf_KIDS) 47 mod(cLISTOPo->op_last, type); 47 break; case OP_NULL: 204277 localize = 0; 204277 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ 706 goto nomod; 203571 else if (!(o->op_flags & OPf_KIDS)) 1 break; 203570 if (o->op_targ != OP_LIST) { 6625 mod(cBINOPo->op_first, type); 6625 break; } /* FALL THROUGH */ case OP_LIST: 292295 localize = 0; 1067644 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 775350 mod(kid, type); 6 break; case OP_RETURN: 6 if (type != OP_LEAVESUBLV) ###### goto nomod; 3462827 break; /* mod()ing was handled by ck_return() */ } /* [20011101.069] File test operators interpret OPf_REF to mean that their argument is a filehandle; thus \stat(".") should not set it. AMS 20011102 */ 3462827 if (type == OP_REFGEN && PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)) 4 return o; 3462823 if (type != OP_LEAVESUBLV) 3462722 o->op_flags |= OPf_MOD; 3462823 if (type == OP_AASSIGN || type == OP_SASSIGN) 1201076 o->op_flags |= OPf_SPECIAL|OPf_REF; 2261747 else if (!type) { /* local() */ 58000 switch (localize) { case 1: 45520 o->op_private |= OPpLVAL_INTRO; 45520 o->op_flags &= ~OPf_SPECIAL; 45520 PL_hints |= HINT_BLOCK_SCOPE; 45520 break; case 0: 30 break; case -1: 30 if (ckWARN(WARN_SYNTAX)) { 28 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Useless localization of %s", OP_DESC(o)); } } } 2203747 else if (type != OP_GREPSTART && type != OP_ENTERSUB && type != OP_LEAVESUBLV) 1047079 o->op_flags |= OPf_REF; 3462823 return o; } STATIC bool S_scalar_mod_type(pTHX_ const OP *o, I32 type) 508786 { 508786 switch (type) { case OP_SASSIGN: 24665 if (o->op_type == OP_RV2GV) 24665 return FALSE; /* FALL THROUGH */ case OP_PREINC: case OP_PREDEC: case OP_POSTINC: case OP_POSTDEC: case OP_I_PREINC: case OP_I_PREDEC: case OP_I_POSTINC: case OP_I_POSTDEC: case OP_POW: case OP_MULTIPLY: case OP_DIVIDE: case OP_MODULO: case OP_REPEAT: case OP_ADD: case OP_SUBTRACT: case OP_I_MULTIPLY: case OP_I_DIVIDE: case OP_I_MODULO: case OP_I_ADD: case OP_I_SUBTRACT: case OP_LEFT_SHIFT: case OP_RIGHT_SHIFT: case OP_BIT_AND: case OP_BIT_XOR: case OP_BIT_OR: case OP_CONCAT: case OP_SUBST: case OP_TRANS: case OP_READ: case OP_SYSREAD: case OP_RECV: case OP_ANDASSIGN: case OP_ORASSIGN: 2 return TRUE; default: 484119 return FALSE; } } STATIC bool S_is_handle_constructor(pTHX_ const OP *o, I32 numargs) 10881 { 10881 switch (o->op_type) { case OP_PIPE_OP: case OP_SOCKPAIR: 140 if (numargs == 2) 70 return TRUE; /* FALL THROUGH */ case OP_SYSOPEN: case OP_OPEN: case OP_SELECT: /* XXX c.f. SelectSaver.pm */ case OP_SOCKET: case OP_OPEN_DIR: case OP_ACCEPT: 3895 if (numargs == 1) 3883 return TRUE; /* FALL THROUGH */ default: 6928 return FALSE; } } OP * Perl_refkids(pTHX_ OP *o, I32 type) 91533 { 91533 if (o && o->op_flags & OPf_KIDS) { 91533 OP *kid; 183066 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 91533 ref(kid, type); } 91533 return o; } OP * Perl_ref(pTHX_ OP *o, I32 type) 2387799 { dVAR; 2387799 OP *kid; 2387799 if (!o || PL_error_count) 3 return o; 2387796 switch (o->op_type) { case OP_ENTERSUB: 10696 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { 8712 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 8712 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 8712 assert(cUNOPo->op_first->op_type == OP_NULL); 8712 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ 8712 o->op_flags |= OPf_SPECIAL; } 8712 break; case OP_COND_EXPR: 15 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 10 ref(kid, type); 20894 break; case OP_RV2SV: 20894 if (type == OP_DEFINED) 9073 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 20894 ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_PADSV: 456588 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 366432 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : type == OP_RV2HV ? OPpDEREF_HV : OPpDEREF_SV); 366432 o->op_flags |= OPf_MOD; } 366432 break; case OP_THREADSV: ###### o->op_flags |= OPf_MOD; /* XXX ??? */ ###### break; case OP_RV2AV: case OP_RV2HV: 645881 o->op_flags |= OPf_REF; /* FALL THROUGH */ case OP_RV2GV: 708066 if (type == OP_DEFINED) 78 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 708066 ref(cUNOPo->op_first, o->op_type); 708066 break; case OP_PADAV: case OP_PADHV: 142682 o->op_flags |= OPf_REF; 142682 break; case OP_SCALAR: case OP_NULL: 2660 if (!(o->op_flags & OPf_KIDS)) ###### break; 2660 ref(cBINOPo->op_first, type); 2660 break; case OP_AELEM: case OP_HELEM: 55551 ref(cBINOPo->op_first, o->op_type); 55551 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 39697 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : type == OP_RV2HV ? OPpDEREF_HV : OPpDEREF_SV); 39697 o->op_flags |= OPf_MOD; } 39697 break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: case OP_LIST: 72449 if (!(o->op_flags & OPf_KIDS)) ###### break; 72449 ref(cLISTOPo->op_last, type); break; default: 2387796 break; } 2387796 return scalar(o); } STATIC OP * S_dup_attrlist(pTHX_ OP *o) 77 { 77 OP *rop = Nullop; /* An attrlist is either a simple OP_CONST or an OP_LIST with kids, * where the first kid is OP_PUSHMARK and the remaining ones * are OP_CONST. We need to push the OP_CONST values. */ 77 if (o->op_type == OP_CONST) 70 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv)); else { 7 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); 28 for (o = cLISTOPo->op_first; o; o=o->op_sibling) { 21 if (o->op_type == OP_CONST) 14 rop = append_elem(OP_LIST, rop, newSVOP(OP_CONST, o->op_flags, 14 SvREFCNT_inc(cSVOPo->op_sv))); } } 77 return rop; } STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) 77 { dVAR; 77 SV *stashsv; /* fake up C */ 77 ENTER; /* need to protect against side-effects of 'use' */ 77 SAVEINT(PL_expect); 77 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; #define ATTRSMODULE "attributes" #define ATTRSMODULE_PM "attributes.pm" 77 if (for_my) { /* Don't force the C if we don't need it. */ 44 SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, 44 sizeof(ATTRSMODULE_PM)-1, 0); 44 if (svp && *svp != &PL_sv_undef) ; /* already in %INC */ else ###### Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), Nullsv); } else { 33 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), Nullsv, prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, stashsv), prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newRV(target)), dup_attrlist(attrs)))); } 70 LEAVE; } STATIC void S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) 44 { 44 OP *pack, *imop, *arg; 44 SV *meth, *stashsv; 44 if (!attrs) ###### return; assert(target->op_type == OP_PADSV || target->op_type == OP_PADHV || 44 target->op_type == OP_PADAV); /* Ensure that attributes.pm is loaded. */ 44 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE); /* Need package name for method call. */ 44 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); /* Build up the real arg-list. */ 44 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; 44 arg = newOP(OP_PADSV, 0); 44 arg->op_targ = target->op_targ; 44 arg = prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, stashsv), prepend_elem(OP_LIST, newUNOP(OP_REFGEN, 0, mod(arg, OP_REFGEN)), dup_attrlist(attrs))); /* Fake up a method call to import */ 44 meth = newSVpvn_share("import", 6, 0); 44 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(arg)), newSVOP(OP_METHOD_NAMED, 0, meth))); 44 imop->op_private |= OPpENTERSUB_NOMOD; /* Combine the ops. */ 44 *imopsp = append_elem(OP_LIST, *imopsp, imop); } /* =notfor apidoc apply_attrs_string Attempts to apply a list of attributes specified by the C and C arguments to the subroutine identified by the C argument which is expected to be associated with the package identified by the C argument (see L). It gets this wrong, though, in that it does not correctly identify the boundaries of the individual attribute specifications within C. This is not really intended for the public API, but has to be listed here for systems such as AIX which need an explicit export list for symbols. (It's called from XS code in support of the C keyword from F.) Patches to fix it to respect attribute syntax properly would be welcome. =cut */ void Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, const char *attrstr, STRLEN len) ###### { ###### OP *attrs = Nullop; ###### if (!len) { ###### len = strlen(attrstr); } ###### while (len) { ###### for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; ###### if (len) { ###### const char *sstr = attrstr; ###### for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; ###### attrs = append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, newSVpvn(sstr, attrstr-sstr))); } } ###### Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), Nullsv, prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newRV((SV*)cv)), attrs))); } STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) 804990 { 804990 I32 type; 804990 if (!o || PL_error_count) 10 return o; 804980 type = o->op_type; 804980 if (type == OP_LIST) { 84786 OP *kid; 410750 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 325964 my_kid(kid, attrs, imopsp); 720194 } else if (type == OP_UNDEF) { 327 return o; 719867 } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ 46669 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ 6 yyerror(Perl_form(aTHX_ "Can't declare %s in %s", OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); 46663 } else if (attrs) { 2 GV *gv = cGVOPx_gv(cUNOPo->op_first); 2 PL_in_my = FALSE; 2 PL_in_my_stash = Nullhv; 2 apply_attrs(GvSTASH(gv), (type == OP_RV2SV ? GvSV(gv) : type == OP_RV2AV ? (SV*)GvAV(gv) : type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv), attrs, FALSE); } 46669 o->op_private |= OPpOUR_INTRO; 46669 return o; } 673198 else if (type != OP_PADSV && type != OP_PADAV && type != OP_PADHV && type != OP_PUSHMARK) { ###### yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); ###### return o; } 673198 else if (attrs && type != OP_PUSHMARK) { 44 HV *stash; 44 PL_in_my = FALSE; 44 PL_in_my_stash = Nullhv; /* check for C when deciding package */ 44 stash = PAD_COMPNAME_TYPE(o->op_targ); 44 if (!stash) 37 stash = PL_curstash; 44 apply_attrs_my(stash, o, attrs, imopsp); } 757984 o->op_flags |= OPf_MOD; 757984 o->op_private |= OPpLVAL_INTRO; 757984 return o; } OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs) 479026 { 479026 OP *rops = Nullop; 479026 int maybe_scalar = 0; /* [perl #17376]: this appears to be premature, and results in code such as C< our(%x); > executing in list mode rather than void mode */ #if 0 if (o->op_flags & OPf_PARENS) list(o); else maybe_scalar = 1; #else 479026 maybe_scalar = 1; #endif 479026 if (attrs) 46 SAVEFREEOP(attrs); 479026 o = my_kid(o, attrs, &rops); 479026 if (rops) { 42 if (maybe_scalar && o->op_type == OP_PADSV) { 26 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o)); 26 o->op_private |= OPpLVAL_INTRO; } else 16 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); } 479026 PL_in_my = FALSE; 479026 PL_in_my_stash = Nullhv; 479026 return o; } OP * Perl_my(pTHX_ OP *o) 478132 { 478132 return my_attrs(o, Nullop); } OP * Perl_sawparens(pTHX_ OP *o) 378092 { 378092 if (o) 378092 o->op_flags |= OPf_PARENS; 378092 return o; } OP * Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) 130387 { 130387 OP *o; 130387 bool ismatchop = 0; 130387 if (ckWARN(WARN_MISC) && (left->op_type == OP_RV2AV || left->op_type == OP_RV2HV || left->op_type == OP_PADAV || left->op_type == OP_PADHV)) { 12 const char *desc = PL_op_desc[(right->op_type == OP_SUBST || right->op_type == OP_TRANS) 12 ? right->op_type : OP_MATCH]; 12 const char *sample = ((left->op_type == OP_RV2AV || left->op_type == OP_PADAV) 12 ? "@array" : "%hash"); 12 Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %s will act on scalar(%s)", desc, sample, sample); } 130387 if (right->op_type == OP_CONST && cSVOPx(right)->op_private & OPpCONST_BARE && cSVOPx(right)->op_private & OPpCONST_STRICT) { 1 no_bareword_allowed(right); } 130387 ismatchop = right->op_type == OP_MATCH || right->op_type == OP_SUBST || right->op_type == OP_TRANS; 130387 if (ismatchop && right->op_private & OPpTARGET_MY) { 16 right->op_targ = 0; 16 right->op_private &= ~OPpTARGET_MY; } 130387 if (!(right->op_flags & OPf_STACKED) && ismatchop) { 124281 right->op_flags |= OPf_STACKED; 124281 if (right->op_type != OP_MATCH && ! (right->op_type == OP_TRANS && right->op_private & OPpTRANS_IDENTICAL)) 48428 left = mod(left, right->op_type); 124281 if (right->op_type == OP_TRANS) 4873 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); else 119408 o = prepend_elem(right->op_type, scalar(left), right); 124281 if (type == OP_NOT) 11589 return newUNOP(OP_NOT, 0, scalar(o)); 112692 return o; } else 6106 return bind_match(type, left, pmruntime(newPMOP(OP_MATCH, 0), right, 0)); } OP * Perl_invert(pTHX_ OP *o) 22605 { 22605 if (!o) ###### return o; /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */ 22605 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); } OP * Perl_scope(pTHX_ OP *o) 443748 { dVAR; 443748 if (o) { 443748 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { 292800 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); 292800 o->op_type = OP_LEAVE; 292800 o->op_ppaddr = PL_ppaddr[OP_LEAVE]; } 150948 else if (o->op_type == OP_LINESEQ) { 149892 OP *kid; 149892 o->op_type = OP_SCOPE; 149892 o->op_ppaddr = PL_ppaddr[OP_SCOPE]; 149892 kid = ((LISTOP*)o)->op_first; 149892 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) 149892 op_null(kid); } else 1056 o = newLISTOP(OP_SCOPE, 0, o, Nullop); } 443748 return o; } /* XXX kept for BINCOMPAT only */ void Perl_save_hints(pTHX) ###### { ###### Perl_croak(aTHX_ "internal error: obsolete function save_hints() called"); } int Perl_block_start(pTHX_ int full) 1080196 { 1080196 const int retval = PL_savestack_ix; 1080196 pad_block_start(full); 1080196 SAVEHINTS(); 1080196 PL_hints &= ~HINT_BLOCK_SCOPE; 1080196 SAVESPTR(PL_compiling.cop_warnings); 1080196 if (! specialWARN(PL_compiling.cop_warnings)) { 14317 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; 14317 SAVEFREESV(PL_compiling.cop_warnings) ; } 1080196 SAVESPTR(PL_compiling.cop_io); 1080196 if (! specialCopIO(PL_compiling.cop_io)) { 3 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ; 3 SAVEFREESV(PL_compiling.cop_io) ; } 1080196 return retval; } OP* Perl_block_end(pTHX_ I32 floor, OP *seq) 1079382 { 1079382 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; 1079382 OP* retval = scalarseq(seq); 1079379 LEAVE_SCOPE(floor); 1079379 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 1079379 if (needblockscope) 754568 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ 1079379 pad_leavemy(); 1079379 return retval; } STATIC OP * S_newDEFSVOP(pTHX) 5878 { 5878 const I32 offset = pad_findmy("$_"); 5878 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { 5871 return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); } else { 7 OP *o = newOP(OP_PADSV, 0); 7 o->op_targ = offset; 7 return o; } } void Perl_newPROG(pTHX_ OP *o) 92813 { 92813 if (PL_in_eval) { 88965 if (PL_eval_root) ###### return; 88965 PL_eval_root = newUNOP(OP_LEAVEEVAL, ((PL_in_eval & EVAL_KEEPERR) ? OPf_SPECIAL : 0), o); 88964 PL_eval_start = linklist(PL_eval_root); 88964 PL_eval_root->op_private |= OPpREFCOUNTED; 88964 OpREFCNT_set(PL_eval_root, 1); 88964 PL_eval_root->op_next = 0; 88964 CALL_PEEP(PL_eval_start); } else { 3848 if (o->op_type == OP_STUB) { 51 PL_comppad_name = 0; 51 PL_compcv = 0; 51 FreeOp(o); 51 return; } 3797 PL_main_root = scope(sawparens(scalarvoid(o))); 3797 PL_curcop = &PL_compiling; 3797 PL_main_start = LINKLIST(PL_main_root); 3797 PL_main_root->op_private |= OPpREFCOUNTED; 3797 OpREFCNT_set(PL_main_root, 1); 3797 PL_main_root->op_next = 0; 3797 CALL_PEEP(PL_main_start); 3797 PL_compcv = 0; /* Register with debugger */ 3797 if (PERLDB_INTER) { 1 CV *cv = get_cv("DB::postponed", FALSE); 1 if (cv) { ###### dSP; ###### PUSHMARK(SP); ###### XPUSHs((SV*)CopFILEGV(&PL_compiling)); ###### PUTBACK; ###### call_sv((SV*)cv, G_DISCARD); } } } } OP * Perl_localize(pTHX_ OP *o, I32 lex) 491899 { 491899 if (o->op_flags & OPf_PARENS) /* [perl #17376]: this appears to be premature, and results in code such as C< our(%x); > executing in list mode rather than void mode */ #if 0 list(o); #else ; #endif else { 374026 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') { 388 char *s = PL_bufptr; 388 bool sigil = FALSE; /* some heuristics to detect a potential error */ 757 while (*s && (strchr(", \t\n", *s))) 369 s++; 644 while (1) { 644 if (*s && strchr("@$%*", *s) && *++s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) { 256 s++; 256 sigil = TRUE; 1023 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) 767 s++; 266 while (*s && (strchr(", \t\n", *s))) 10 s++; } else 388 break; } 388 if (sigil && (*s == ';' || *s == '=')) { 5 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), "Parentheses missing around \"%s\" list", lex ? (PL_in_my == KEY_our ? "our" : "my") : "local"); } } } 491899 if (lex) 454897 o = my(o); else 37002 o = mod(o, OP_NULL); /* a bit kludgey */ 491898 PL_in_my = FALSE; 491898 PL_in_my_stash = Nullhv; 491898 return o; } OP * Perl_jmaybe(pTHX_ OP *o) 363792 { 363792 if (o->op_type == OP_LIST) { 319 OP *o2; 319 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); } 363792 return o; } OP * Perl_fold_constants(pTHX_ register OP *o) 7844394 { dVAR; 7844394 register OP *curop; 7844394 I32 type = o->op_type; 7844394 SV *sv; 7844394 if (PL_opargs[type] & OA_RETSCALAR) 4212522 scalar(o); 7844394 if (PL_opargs[type] & OA_TARGET && !o->op_targ) 2902338 o->op_targ = pad_alloc(type, SVs_PADTMP); /* integerize op, unless it happens to be C<-foo>. * XXX should pp_i_negate() do magic string negation instead? */ 7844394 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER) && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST && (cUNOPo->op_first->op_private & OPpCONST_BARE))) { 7842 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)]; } 7844394 if (!(PL_opargs[type] & OA_FOLDCONST)) 6288381 goto nope; 1556013 switch (type) { case OP_NEGATE: /* XXX might want a ck_negate() for this */ 23444 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; 23444 break; case OP_SPRINTF: case OP_UCFIRST: case OP_LCFIRST: case OP_UC: case OP_LC: case OP_SLT: case OP_SGT: case OP_SLE: case OP_SGE: case OP_SCMP: /* XXX what about the numeric ops? */ 28437 if (PL_hints & HINT_LOCALE) 11157 goto nope; } 1544856 if (PL_error_count) 29 goto nope; /* Don't try to run w/ errors */ 3032026 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 2779119 if ((curop->op_type != OP_CONST || (curop->op_private & OPpCONST_BARE)) && curop->op_type != OP_LIST && curop->op_type != OP_SCALAR && curop->op_type != OP_NULL && curop->op_type != OP_PUSHMARK) { 1291920 goto nope; } } 252907 curop = LINKLIST(o); 252907 o->op_next = 0; 252907 PL_op = curop; 252907 CALLRUNOPS(aTHX); 252904 sv = *(PL_stack_sp--); 252904 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ 251054 pad_swipe(o->op_targ, FALSE); 1850 else if (SvTEMP(sv)) { /* grab mortal temp? */ 410 (void)SvREFCNT_inc(sv); 410 SvTEMP_off(sv); } 252904 op_free(o); 252904 if (type == OP_RV2GV) ###### return newGVOP(OP_GV, 0, (GV*)sv); 252904 return newSVOP(OP_CONST, 0, sv); nope: 7591487 return o; } OP * Perl_gen_constant_list(pTHX_ register OP *o) 1028 { dVAR; 1028 register OP *curop; 1028 const I32 oldtmps_floor = PL_tmps_floor; 1028 list(o); 1028 if (PL_error_count) ###### return o; /* Don't attempt to run with errors */ 1028 PL_op = curop = LINKLIST(o); 1028 o->op_next = 0; 1028 CALL_PEEP(curop); 1028 pp_pushmark(); 1028 CALLRUNOPS(aTHX); 1028 PL_op = curop; 1028 pp_anonlist(); 1028 PL_tmps_floor = oldtmps_floor; 1028 o->op_type = OP_RV2AV; 1028 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 1028 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ 1028 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ 1028 o->op_opt = 0; /* needs to be revisited in peep() */ 1028 curop = ((UNOP*)o)->op_first; 1028 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--)); 1028 op_free(curop); 1028 linklist(o); 1028 return list(o); } OP * Perl_convert(pTHX_ I32 type, I32 flags, OP *o) 1209235 { dVAR; 1209235 if (!o || o->op_type != OP_LIST) 689267 o = newLISTOP(OP_LIST, 0, o, Nullop); else 519968 o->op_flags &= ~OPf_WANT; 1209234 if (!(PL_opargs[type] & OA_MARK)) 547354 op_null(cLISTOPo->op_first); 1209234 o->op_type = (OPCODE)type; 1209234 o->op_ppaddr = PL_ppaddr[type]; 1209234 o->op_flags |= flags; 1209234 o = CHECKOP(type, o); 1209141 if (o->op_type != (unsigned)type) 22288 return o; 1186853 return fold_constants(o); } /* List constructors */ OP * Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) 2727098 { 2727098 if (!first) 108082 return last; 2619016 if (!last) 33052 return first; 2585964 if (first->op_type != (unsigned)type || (type == OP_LIST && (first->op_flags & OPf_PARENS))) { 880493 return newLISTOP(type, 0, first, last); } 1705471 if (first->op_flags & OPf_KIDS) 1705471 ((LISTOP*)first)->op_last->op_sibling = last; else { ###### first->op_flags |= OPf_KIDS; ###### ((LISTOP*)first)->op_first = last; } 1705471 ((LISTOP*)first)->op_last = last; 1705471 return first; } OP * Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) 2904907 { 2904907 if (!first) 818470 return (OP*)last; 2086437 if (!last) 611994 return (OP*)first; 1474443 if (first->op_type != (unsigned)type) 13157 return prepend_elem(type, (OP*)first, (OP*)last); 1461286 if (last->op_type != (unsigned)type) 56514 return append_elem(type, (OP*)first, (OP*)last); 1404772 first->op_last->op_sibling = last->op_first; 1404772 first->op_last = last->op_last; 1404772 first->op_flags |= (last->op_flags & OPf_KIDS); 1404772 FreeOp(last); 1404772 return (OP*)first; } OP * Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) 3128853 { 3128853 if (!first) ###### return last; 3128853 if (!last) 111202 return first; 3017651 if (last->op_type == (unsigned)type) { 544483 if (type == OP_LIST) { /* already a PUSHMARK there */ 54405 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; 54405 ((LISTOP*)last)->op_first->op_sibling = first; 54405 if (!(first->op_flags & OPf_PARENS)) 54350 last->op_flags &= ~OPf_PARENS; } else { 490078 if (!(last->op_flags & OPf_KIDS)) { 129368 ((LISTOP*)last)->op_last = first; 129368 last->op_flags |= OPf_KIDS; } 490078 first->op_sibling = ((LISTOP*)last)->op_first; 490078 ((LISTOP*)last)->op_first = first; } 544483 last->op_flags |= OPf_KIDS; 544483 return last; } 2473168 return newLISTOP(type, 0, first, last); } /* Constructors */ OP * Perl_newNULLLIST(pTHX) 18716 { 18716 return newOP(OP_STUB, 0); } OP * Perl_force_list(pTHX_ OP *o) 979900 { 979900 if (!o || o->op_type != OP_LIST) 602972 o = newLISTOP(OP_LIST, 0, o, Nullop); 979900 op_null(o); 979900 return o; } OP * Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 4660905 { dVAR; 4660905 LISTOP *listop; 4660905 NewOp(1101, listop, 1, LISTOP); 4660905 listop->op_type = (OPCODE)type; 4660905 listop->op_ppaddr = PL_ppaddr[type]; 4660905 if (first || last) 4632378 flags |= OPf_KIDS; 4660905 listop->op_flags = (U8)flags; 4660905 if (!last && first) 1264768 last = first; 3396137 else if (!first && last) ###### first = last; 3396137 else if (first) 3367610 first->op_sibling = last; 4660905 listop->op_first = first; 4660905 listop->op_last = last; 4660905 if (type == OP_LIST) { 2301385 OP* pushop; 2301385 pushop = newOP(OP_PUSHMARK, 0); 2301384 pushop->op_sibling = first; 2301384 listop->op_first = pushop; 2301384 listop->op_flags |= OPf_KIDS; 2301384 if (!last) 28527 listop->op_last = pushop; } 4660904 return CHECKOP(type, listop); } OP * Perl_newOP(pTHX_ I32 type, I32 flags) 5790078 { dVAR; 5790078 OP *o; 5790078 NewOp(1101, o, 1, OP); 5790078 o->op_type = (OPCODE)type; 5790078 o->op_ppaddr = PL_ppaddr[type]; 5790078 o->op_flags = (U8)flags; 5790078 o->op_next = o; 5790078 o->op_private = (U8)(0 | (flags >> 8)); 5790078 if (PL_opargs[type] & OA_RETSCALAR) 2535977 scalar(o); 5790078 if (PL_opargs[type] & OA_TARGET) 12429 o->op_targ = pad_alloc(type, SVs_PADTMP); 5790078 return CHECKOP(type, o); } OP * Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) 4502603 { dVAR; 4502603 UNOP *unop; 4502603 if (!first) ###### first = newOP(OP_STUB, 0); 4502603 if (PL_opargs[type] & OA_MARK) 495208 first = force_list(first); 4502603 NewOp(1101, unop, 1, UNOP); 4502603 unop->op_type = (OPCODE)type; 4502603 unop->op_ppaddr = PL_ppaddr[type]; 4502603 unop->op_first = first; 4502603 unop->op_flags = flags | OPf_KIDS; 4502603 unop->op_private = (U8)(1 | (flags >> 8)); 4502603 unop = (UNOP*) CHECKOP(type, unop); 4502532 if (unop->op_next) 215164 return (OP*)unop; 4287368 return fold_constants((OP *) unop); } OP * Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 2394951 { dVAR; 2394951 BINOP *binop; 2394951 NewOp(1101, binop, 1, BINOP); 2394951 if (!first) ###### first = newOP(OP_NULL, 0); 2394951 binop->op_type = (OPCODE)type; 2394951 binop->op_ppaddr = PL_ppaddr[type]; 2394951 binop->op_first = first; 2394951 binop->op_flags = flags | OPf_KIDS; 2394951 if (!last) { ###### last = first; ###### binop->op_private = (U8)(1 | (flags >> 8)); } else { 2394951 binop->op_private = (U8)(2 | (flags >> 8)); 2394951 first->op_sibling = last; } 2394951 binop = (BINOP*)CHECKOP(type, binop); 2394916 if (binop->op_next || binop->op_type != (OPCODE)type) 24828 return (OP*)binop; 2370088 binop->op_last = binop->op_first->op_sibling; 2370088 return fold_constants((OP *)binop); } static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__; static int uvcompare(const void *a, const void *b) 2050 { 2050 if (*((const UV *)a) < (*(const UV *)b)) 2050 return -1; ###### if (*((const UV *)a) > (*(const UV *)b)) ###### return 1; ###### if (*((const UV *)a+1) < (*(const UV *)b+1)) ###### return -1; ###### if (*((const UV *)a+1) > (*(const UV *)b+1)) ###### return 1; ###### return 0; } OP * Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 5123 { 5123 SV *tstr = ((SVOP*)expr)->op_sv; 5123 SV *rstr = ((SVOP*)repl)->op_sv; 5123 STRLEN tlen; 5123 STRLEN rlen; 5123 const U8 *t = (U8*)SvPV_const(tstr, tlen); 5123 const U8 *r = (U8*)SvPV_const(rstr, rlen); 5123 register I32 i; 5123 register I32 j; 5123 I32 del; 5123 I32 complement; 5123 I32 squash; 5123 I32 grows = 0; 5123 register short *tbl; 5123 PL_hints |= HINT_BLOCK_SCOPE; 5123 complement = o->op_private & OPpTRANS_COMPLEMENT; 5123 del = o->op_private & OPpTRANS_DELETE; 5123 squash = o->op_private & OPpTRANS_SQUASH; 5123 if (SvUTF8(tstr)) 42 o->op_private |= OPpTRANS_FROM_UTF; 5123 if (SvUTF8(rstr)) 43 o->op_private |= OPpTRANS_TO_UTF; 5123 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { 47 SV* listsv = newSVpvn("# comment\n",10); 47 SV* transv = 0; 47 const U8* tend = t + tlen; 47 const U8* rend = r + rlen; 47 STRLEN ulen; 47 UV tfirst = 1; 47 UV tlast = 0; 47 IV tdiff; 47 UV rfirst = 1; 47 UV rlast = 0; 47 IV rdiff; 47 IV diff; 47 I32 none = 0; 47 U32 max = 0; 47 I32 bits; 47 I32 havefinal = 0; 47 U32 final = 0; 47 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; 47 I32 to_utf = o->op_private & OPpTRANS_TO_UTF; 47 U8* tsave = NULL; 47 U8* rsave = NULL; 47 if (!from_utf) { 5 STRLEN len = tlen; 5 t = tsave = bytes_to_utf8(t, &len); 5 tend = t + len; } 47 if (!to_utf && rlen) { ###### STRLEN len = rlen; ###### r = rsave = bytes_to_utf8(r, &len); ###### rend = r + len; } /* There are several snags with this code on EBCDIC: 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes). 2. scan_const() in toke.c has encoded chars in native encoding which makes ranges at least in EBCDIC 0..255 range the bottom odd. */ 47 if (complement) { 8 U8 tmpbuf[UTF8_MAXBYTES+1]; 8 UV *cp; 8 UV nextmin = 0; 8 New(1109, cp, 2*tlen, UV); 8 i = 0; 8 transv = newSVpvn("",0); 528 while (t < tend) { 520 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0); 520 t += ulen; 520 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { 4 t++; 4 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0); 4 t += ulen; } else { 516 cp[2*i+1] = cp[2*i]; } 520 i++; } 8 qsort(cp, i, 2*sizeof(UV), uvcompare); 528 for (j = 0; j < i; j++) { 520 UV val = cp[2*j]; 520 diff = val - nextmin; 520 if (diff > 0) { 6 t = uvuni_to_utf8(tmpbuf,nextmin); 6 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 6 if (diff > 1) { 4 U8 range_mark = UTF_TO_NATIVE(0xff); 4 t = uvuni_to_utf8(tmpbuf, val - 1); 4 sv_catpvn(transv, (char *)&range_mark, 1); 4 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); } } 520 val = cp[2*j+1]; 520 if (val >= nextmin) 520 nextmin = val + 1; } 8 t = uvuni_to_utf8(tmpbuf,nextmin); 8 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); { 8 U8 range_mark = UTF_TO_NATIVE(0xff); 8 sv_catpvn(transv, (char *)&range_mark, 1); } 8 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff, UNICODE_ALLOW_SUPER); 8 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 8 t = (const U8*)SvPVX_const(transv); 8 tlen = SvCUR(transv); 8 tend = t + tlen; 8 Safefree(cp); } 39 else if (!rlen && !del) { ###### r = t; rlen = tlen; rend = tend; } 47 if (!squash) { 44 if ((!rlen && !del) || t == r || (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) { 4 o->op_private |= OPpTRANS_IDENTICAL; } } 141 while (t < tend || tfirst <= tlast) { /* see if we need more "t" chars */ 94 if (tfirst > tlast) { 89 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); 89 t += ulen; 89 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ 32 t++; 32 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); 32 t += ulen; } else 57 tlast = tfirst; } /* now see if we need more "r" chars */ 94 if (rfirst > rlast) { 86 if (r < rend) { 75 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); 75 r += ulen; 75 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ 20 r++; 20 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); 20 r += ulen; } else 55 rlast = rfirst; } else { 11 if (!havefinal++) 11 final = rlast; 11 rfirst = rlast = 0xffffffff; } } /* now see which range will peter our first, if either. */ 94 tdiff = tlast - tfirst; 94 rdiff = rlast - rfirst; 94 if (tdiff <= rdiff) 76 diff = tdiff; else 18 diff = rdiff; 94 if (rfirst == 0xffffffff) { 15 diff = tdiff; /* oops, pretend rdiff is infinite */ 15 if (diff > 0) 13 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n", (long)tfirst, (long)tlast); else 2 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst); } else { 79 if (diff > 0) 19 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n", (long)tfirst, (long)(tfirst + diff), (long)rfirst); else 60 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n", (long)tfirst, (long)rfirst); 79 if (rfirst + diff > max) 51 max = rfirst + diff; 79 if (!grows) 53 grows = (tfirst < rfirst && UNISKIP(tfirst) < UNISKIP(rfirst + diff)); 79 rfirst += diff + 1; } 94 tfirst += diff + 1; } 47 none = ++max; 47 if (del) 2 del = ++max; 47 if (max > 0xffff) ###### bits = 32; 47 else if (max > 0xff) 33 bits = 16; else 14 bits = 8; 47 Safefree(cPVOPo->op_pv); 47 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none); 47 SvREFCNT_dec(listsv); 47 if (transv) 8 SvREFCNT_dec(transv); 47 if (!del && havefinal && rlen) 7 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, newSVuv((UV)final), 0); 47 if (grows) 5 o->op_private |= OPpTRANS_GROWS; 47 if (tsave) 5 Safefree(tsave); 47 if (rsave) ###### Safefree(rsave); 47 op_free(expr); 47 op_free(repl); 47 return o; } 5076 tbl = (short*)cPVOPo->op_pv; 5076 if (complement) { 183 Zero(tbl, 256, short); 12555 for (i = 0; i < (I32)tlen; i++) 12372 tbl[t[i]] = -1; 47031 for (i = 0, j = 0; i < 256; i++) { 46848 if (!tbl[i]) { 34476 if (j >= (I32)rlen) { 34476 if (del) 29765 tbl[i] = -2; 4711 else if (rlen) ###### tbl[i] = r[j-1]; else 4711 tbl[i] = (short)i; } else { ###### if (i < 128 && r[j] >= 128) ###### grows = 1; ###### tbl[i] = r[j++]; } } } 183 if (!del) { 33 if (!rlen) { 29 j = rlen; 29 if (!squash) 26 o->op_private |= OPpTRANS_IDENTICAL; } 4 else if (j >= (I32)rlen) ###### j = rlen - 1; else 4 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short); 33 tbl[0x100] = rlen - j; 39 for (i=0; i < (I32)rlen - j; i++) 6 tbl[0x101+i] = r[j+i]; } } else { 4893 if (!rlen && !del) { 1923 r = t; rlen = tlen; 1923 if (!squash) 1923 o->op_private |= OPpTRANS_IDENTICAL; } 2970 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) { 47 o->op_private |= OPpTRANS_IDENTICAL; } 1257501 for (i = 0; i < 256; i++) 1252608 tbl[i] = -1; 111596 for (i = 0, j = 0; i < (I32)tlen; i++,j++) { 106703 if (j >= (I32)rlen) { 20276 if (del) { 13577 if (tbl[t[i]] == -1) 12865 tbl[t[i]] = -2; 12865 continue; } 6699 --j; } 93126 if (tbl[t[i]] == -1) { 93122 if (t[i] < 128 && r[j] >= 128) 2826 grows = 1; 93122 tbl[t[i]] = r[j]; } } } 5076 if (grows) 32 o->op_private |= OPpTRANS_GROWS; 5076 op_free(expr); 5076 op_free(repl); 5076 return o; } OP * Perl_newPMOP(pTHX_ I32 type, I32 flags) 160257 { dVAR; 160257 PMOP *pmop; 160257 NewOp(1101, pmop, 1, PMOP); 160257 pmop->op_type = (OPCODE)type; 160257 pmop->op_ppaddr = PL_ppaddr[type]; 160257 pmop->op_flags = (U8)flags; 160257 pmop->op_private = (U8)(0 | (flags >> 8)); 160257 if (PL_hints & HINT_RE_TAINT) 9748 pmop->op_pmpermflags |= PMf_RETAINT; 160257 if (PL_hints & HINT_LOCALE) 504 pmop->op_pmpermflags |= PMf_LOCALE; 160257 pmop->op_pmflags = pmop->op_pmpermflags; #ifdef USE_ITHREADS { SV* repointer; if(av_len((AV*) PL_regex_pad[0]) > -1) { repointer = av_pop((AV*)PL_regex_pad[0]); pmop->op_pmoffset = SvIV(repointer); SvREPADTMP_off(repointer); sv_setiv(repointer,0); } else { repointer = newSViv(0); av_push(PL_regex_padav,SvREFCNT_inc(repointer)); pmop->op_pmoffset = av_len(PL_regex_padav); PL_regex_pad = AvARRAY(PL_regex_padav); } } #endif /* link into pm list */ 160257 if (type != OP_TRANS && PL_curstash) { 160257 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab); 160257 if (!mg) { 15488 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0); } 160257 pmop->op_pmnext = (PMOP*)mg->mg_obj; 160257 mg->mg_obj = (SV*)pmop; 160257 PmopSTASH_set(pmop,PL_curstash); } 160257 return CHECKOP(type, pmop); } /* Given some sort of match op o, and an expression expr containing a * pattern, either compile expr into a regex and attach it to o (if it's * constant), or convert expr into a runtime regcomp op sequence (if it's * not) * * isreg indicates that the pattern is part of a regex construct, eg * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or * split "pattern", which aren't. In the former case, expr will be a list * if the pattern contains more than one term (eg /a$b/) or if it contains * a replacement, ie s/// or tr///. */ OP * Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) 165375 { dVAR; 165375 PMOP *pm; 165375 LOGOP *rcop; 165375 I32 repl_has_vars = 0; 165375 OP* repl = Nullop; 165375 bool reglist; 165375 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) { /* last element in list is the replacement; pop it */ 58242 OP* kid; 58242 repl = cLISTOPx(expr)->op_last; 58242 kid = cLISTOPx(expr)->op_first; 122881 while (kid->op_sibling != repl) 64639 kid = kid->op_sibling; 58242 kid->op_sibling = Nullop; 58242 cLISTOPx(expr)->op_last = kid; } 165375 if (isreg && expr->op_type == OP_LIST && cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last) { /* convert single element list to element */ 55366 OP* oe = expr; 55366 expr = cLISTOPx(oe)->op_first->op_sibling; 55366 cLISTOPx(oe)->op_first->op_sibling = Nullop; 55366 cLISTOPx(oe)->op_last = Nullop; 55366 op_free(oe); } 165375 if (o->op_type == OP_TRANS) { 5123 return pmtrans(o, expr, repl); } 160252 reglist = isreg && expr->op_type == OP_LIST; 160252 if (reglist) 9158 op_null(expr); 160252 PL_hints |= HINT_BLOCK_SCOPE; 160252 pm = (PMOP*)o; 160252 if (expr->op_type == OP_CONST) { 140591 STRLEN plen; 140591 SV *pat = ((SVOP*)expr)->op_sv; 140591 const char *p = SvPV_const(pat, plen); 140591 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { 918 U32 was_readonly = SvREADONLY(pat); 918 if (was_readonly) { 918 if (SvFAKE(pat)) { ###### sv_force_normal_flags(pat, 0); ###### assert(!SvREADONLY(pat)); ###### was_readonly = 0; } else { 918 SvREADONLY_off(pat); } } 918 sv_setpvn(pat, "\\s+", 3); 918 SvFLAGS(pat) |= was_readonly; 918 p = SvPV_const(pat, plen); 918 pm->op_pmflags |= PMf_SKIPWHITE; } 140591 if (DO_UTF8(pat)) 45 pm->op_pmdynflags |= PMdf_UTF8; /* FIXME - can we make this function take const char * args? */ 140591 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm)); 140360 if (strEQ("\\s+", PM_GETRE(pm)->precomp)) 1790 pm->op_pmflags |= PMf_WHITE; 140360 op_free(expr); } else { 19661 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) 19640 expr = newUNOP((!(PL_hints & HINT_RE_EVAL) ? OP_REGCRESET : OP_REGCMAYBE),0,expr); 19661 NewOp(1101, rcop, 1, LOGOP); 19661 rcop->op_type = OP_REGCOMP; 19661 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; 19661 rcop->op_first = scalar(expr); 19661 rcop->op_flags |= OPf_KIDS | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) | (reglist ? OPf_STACKED : 0); 19661 rcop->op_private = 1; 19661 rcop->op_other = o; 19661 if (reglist) 9158 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP); /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ 19661 PL_cv_has_eval = 1; /* establish postfix order */ 19661 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) { 19640 LINKLIST(expr); 19640 rcop->op_next = expr; 19640 ((UNOP*)expr)->op_first->op_next = (OP*)rcop; } else { 21 rcop->op_next = LINKLIST(expr); 21 expr->op_next = (OP*)rcop; } 19661 prepend_elem(o->op_type, scalar((OP*)rcop), o); } 160021 if (repl) { 53119 OP *curop; 53119 if (pm->op_pmflags & PMf_EVAL) { 3674 curop = 0; 3674 if (CopLINE(PL_curcop) < (line_t)PL_multi_end) 2 CopLINE_set(PL_curcop, (line_t)PL_multi_end); } 49445 else if (repl->op_type == OP_CONST) 40643 curop = repl; else { 8802 OP *lastop = 0; 14395 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { 13342 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 9419 if (curop->op_type == OP_GV) { 7677 GV *gv = cGVOPx_gv(curop); 7677 repl_has_vars = 1; 7677 if (strchr("&`'123456789+-\016\022", *GvENAME(gv))) 7453 break; } 1742 else if (curop->op_type == OP_RV2CV) ###### break; 1742 else if (curop->op_type == OP_RV2SV || curop->op_type == OP_RV2AV || curop->op_type == OP_RV2HV || curop->op_type == OP_RV2GV) { 438 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/ 296 break; } 1304 else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || curop->op_type == OP_PADANY) { 1304 repl_has_vars = 1; } ###### else if (curop->op_type == OP_PUSHRE) ; /* Okay here, dangerous in newASSIGNOP */ else 5593 break; } 5593 lastop = curop; } } 53119 if (curop == repl && !(repl_has_vars && (!PM_GETRE(pm) || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) { 41531 pm->op_pmflags |= PMf_CONST; /* const for long enough */ 41531 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ 41531 prepend_elem(o->op_type, scalar(repl), o); } else { 11588 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */ 163 pm->op_pmflags |= PMf_MAYBE_CONST; 163 pm->op_pmpermflags |= PMf_MAYBE_CONST; } 11588 NewOp(1101, rcop, 1, LOGOP); 11588 rcop->op_type = OP_SUBSTCONT; 11588 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT]; 11588 rcop->op_first = scalar(repl); 11588 rcop->op_flags |= OPf_KIDS; 11588 rcop->op_private = 1; 11588 rcop->op_other = o; /* establish postfix order */ 11588 rcop->op_next = LINKLIST(repl); 11588 repl->op_next = (OP*)rcop; 11588 pm->op_pmreplroot = scalar((OP*)rcop); 11588 pm->op_pmreplstart = LINKLIST(rcop); 11588 rcop->op_next = 0; } } 160021 return (OP*)pm; } OP * Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) 5792867 { dVAR; 5792867 SVOP *svop; 5792867 NewOp(1101, svop, 1, SVOP); 5792867 svop->op_type = (OPCODE)type; 5792867 svop->op_ppaddr = PL_ppaddr[type]; 5792867 svop->op_sv = sv; 5792867 svop->op_next = (OP*)svop; 5792867 svop->op_flags = (U8)flags; 5792867 if (PL_opargs[type] & OA_RETSCALAR) 5522452 scalar((OP*)svop); 5792867 if (PL_opargs[type] & OA_TARGET) 514 svop->op_targ = pad_alloc(type, SVs_PADTMP); 5792867 return CHECKOP(type, svop); } OP * Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) ###### { dVAR; ###### PADOP *padop; ###### NewOp(1101, padop, 1, PADOP); ###### padop->op_type = (OPCODE)type; ###### padop->op_ppaddr = PL_ppaddr[type]; ###### padop->op_padix = pad_alloc(type, SVs_PADTMP); ###### SvREFCNT_dec(PAD_SVl(padop->op_padix)); ###### PAD_SETSV(padop->op_padix, sv); ###### if (sv) ###### SvPADTMP_on(sv); ###### padop->op_next = (OP*)padop; ###### padop->op_flags = (U8)flags; ###### if (PL_opargs[type] & OA_RETSCALAR) ###### scalar((OP*)padop); ###### if (PL_opargs[type] & OA_TARGET) ###### padop->op_targ = pad_alloc(type, SVs_PADTMP); ###### return CHECKOP(type, padop); } OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) 155387 { dVAR; #ifdef USE_ITHREADS if (gv) GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc(gv)); #else 155387 return newSVOP(type, flags, SvREFCNT_inc(gv)); #endif } OP * Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) 13330 { dVAR; 13330 PVOP *pvop; 13330 NewOp(1101, pvop, 1, PVOP); 13330 pvop->op_type = (OPCODE)type; 13330 pvop->op_ppaddr = PL_ppaddr[type]; 13330 pvop->op_pv = pv; 13330 pvop->op_next = (OP*)pvop; 13330 pvop->op_flags = (U8)flags; 13330 if (PL_opargs[type] & OA_RETSCALAR) 13330 scalar((OP*)pvop); 13330 if (PL_opargs[type] & OA_TARGET) ###### pvop->op_targ = pad_alloc(type, SVs_PADTMP); 13330 return CHECKOP(type, pvop); } void Perl_package(pTHX_ OP *o) 28674 { 28674 const char *name; 28674 STRLEN len; 28674 save_hptr(&PL_curstash); 28674 save_item(PL_curstname); 28674 name = SvPV_const(cSVOPo->op_sv, len); 28674 PL_curstash = gv_stashpvn(name, len, TRUE); 28674 sv_setpvn(PL_curstname, name, len); 28674 op_free(o); 28674 PL_hints |= HINT_BLOCK_SCOPE; 28674 PL_copline = NOLINE; 28674 PL_expect = XSTATE; } void Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) 49806 { 49806 OP *pack; 49806 OP *imop; 49806 OP *veop; 49806 if (idop->op_type != OP_CONST) ###### Perl_croak(aTHX_ "Module name must be constant"); 49806 veop = Nullop; 49806 if (version != Nullop) { 196 SV *vesv = ((SVOP*)version)->op_sv; 196 if (arg == Nullop && !SvNIOKp(vesv)) { ###### arg = version; } else { 196 OP *pack; 196 SV *meth; 196 if (version->op_type != OP_CONST || !SvNIOKp(vesv)) ###### Perl_croak(aTHX_ "Version number must be constant number"); /* Make copy of idop so we don't free it twice */ 196 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to VERSION */ 196 meth = newSVpvn_share("VERSION", 7, 0); 196 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(version)), newSVOP(OP_METHOD_NAMED, 0, meth))); } } /* Fake up an import/unimport */ 49806 if (arg && arg->op_type == OP_STUB) 2407 imop = arg; /* no import on explicit () */ 47399 else if (SvNIOKp(((SVOP*)idop)->op_sv)) { 4137 imop = Nullop; /* use 5.0; */ } else { 43262 SV *meth; /* Make copy of idop so we don't free it twice */ 43262 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to import/unimport */ 43262 meth = aver ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0); 43262 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(arg)), newSVOP(OP_METHOD_NAMED, 0, meth))); } /* Fake up the BEGIN {}, which does its thing immediately. */ 49806 newATTRSUB(floor, newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)), Nullop, Nullop, append_elem(OP_LINESEQ, append_elem(OP_LINESEQ, newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)), newSTATEOP(0, Nullch, veop)), newSTATEOP(0, Nullch, imop) )); /* The "did you use incorrect case?" warning used to be here. * The problem is that on case-insensitive filesystems one * might get false positives for "use" (and "require"): * "use Strict" or "require CARP" will work. This causes * portability problems for the script: in case-strict * filesystems the script will stop working. * * The "incorrect case" warning checked whether "use Foo" * imported "Foo" to your namespace, but that is wrong, too: * there is no requirement nor promise in the language that * a Foo.pm should or would contain anything in package "Foo". * * There is very little Configure-wise that can be done, either: * the case-sensitivity of the build filesystem of Perl does not * help in guessing the case-sensitivity of the runtime environment. */ 49671 PL_hints |= HINT_BLOCK_SCOPE; 49671 PL_copline = NOLINE; 49671 PL_expect = XSTATE; 49671 PL_cop_seqmax++; /* Purely for B::*'s benefit */ } /* =head1 Embedding Functions =for apidoc load_module Loads the module whose name is pointed to by the string part of name. Note that the actual module name, not its filename, should be given. Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS (or 0 for no flags). ver, if specified, provides version semantics similar to C. The optional trailing SV* arguments can be used to specify arguments to the module's import() method, similar to C. =cut */ void Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) 365 { 365 va_list args; 365 va_start(args, ver); 365 vload_module(flags, name, ver, &args); va_end(args); } #ifdef PERL_IMPLICIT_CONTEXT void Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) { dTHX; va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif void Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) 365 { 365 OP *modname, *veop, *imop; 365 modname = newSVOP(OP_CONST, 0, name); 365 modname->op_private |= OPpCONST_BARE; 365 if (ver) { 66 veop = newSVOP(OP_CONST, 0, ver); } else 299 veop = Nullop; 365 if (flags & PERL_LOADMOD_NOIMPORT) { 299 imop = sawparens(newNULLLIST()); } 66 else if (flags & PERL_LOADMOD_IMPORT_OPS) { 33 imop = va_arg(*args, OP*); } else { 33 SV *sv; 33 imop = Nullop; 33 sv = va_arg(*args, SV*); 66 while (sv) { 33 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); 33 sv = va_arg(*args, SV*); } } { 365 const line_t ocopline = PL_copline; 365 COP * const ocurcop = PL_curcop; 365 const int oexpect = PL_expect; 365 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); 358 PL_expect = oexpect; 358 PL_copline = ocopline; 358 PL_curcop = ocurcop; } } OP * Perl_dofile(pTHX_ OP *term) 757 { 757 OP *doop; 757 GV *gv; 757 gv = gv_fetchpv("do", FALSE, SVt_PVCV); 757 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) 757 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV); 757 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { ###### doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, term, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv)))))); } else { 757 doop = newUNOP(OP_DOFILE, 0, scalar(term)); } 756 return doop; } OP * Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) 17281 { 17281 return newBINOP(OP_LSLICE, flags, list(force_list(subscript)), list(force_list(listval)) ); } STATIC I32 S_is_list_assignment(pTHX_ register const OP *o) 879074 { 879074 if (!o) ###### return TRUE; 879074 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS) 231 o = cUNOPo->op_first; 879074 if (o->op_type == OP_COND_EXPR) { 231 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); 231 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); 231 if (t && f) ###### return TRUE; 231 if (t || f) ###### yyerror("Assignment to both a list and a scalar"); 231 return FALSE; } 878843 if (o->op_type == OP_LIST && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR && o->op_private & OPpLVAL_INTRO) 1 return FALSE; 878842 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS || o->op_type == OP_RV2AV || o->op_type == OP_RV2HV || o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) 159779 return TRUE; 719063 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) 43066 return TRUE; 675997 if (o->op_type == OP_RV2SV) 132089 return FALSE; 543908 return FALSE; } OP * Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) 966575 { 966575 OP *o; 966575 if (optype) { 87963 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { 15720 return newLOGOP(optype, 0, mod(scalar(left), optype), newUNOP(OP_SASSIGN, 0, scalar(right))); } else { 72243 return newBINOP(optype, OPf_STACKED, mod(scalar(left), optype), scalar(right)); } } 878612 if (is_list_assignment(left)) { 202845 OP *curop; 202845 PL_modcount = 0; /* Grandfathering $[ assignment here. Bletch.*/ /* Only simple assignments like C<< ($[) = 1 >> are allowed */ 202845 PL_eval_start = (left->op_type == OP_CONST) ? right : 0; 202845 left = mod(left, OP_AASSIGN); 202842 if (PL_eval_start) ###### PL_eval_start = 0; 202842 else if (left->op_type == OP_CONST) { /* Result of assignment is always 1 (or we'd be dead already) */ 2 return newSVOP(OP_CONST, 0, newSViv(1)); } /* optimise C to C, and likewise for hashes */ 202840 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV) && right->op_type == OP_STUB && (left->op_private & OPpLVAL_INTRO)) { 3104 op_free(right); 3104 left->op_flags &= ~(OPf_REF|OPf_SPECIAL); 3104 return left; } 199736 curop = list(force_list(left)); 199736 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); 199735 o->op_private = (U8)(0 | (flags >> 8)); /* PL_generation sorcery: * an assignment like ($a,$b) = ($c,$d) is easier than * ($a,$b) = ($c,$a), since there is no need for temporary vars. * To detect whether there are common vars, the global var * PL_generation is incremented for each assign op we compile. * Then, while compiling the assign op, we run through all the * variables on both sides of the assignment, setting a spare slot * in each of them to PL_generation. If any of them already have * that value, we know we've got commonality. We could use a * single bit marker, but then we'd have to make 2 passes, first * to clear the flag, then to test and set it. To find somewhere * to store these values, evil chicanery is done with SvCUR(). */ 199735 if (!(left->op_private & OPpLVAL_INTRO)) { 81945 OP *lastop = o; 81945 PL_generation++; 1416950 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 1371447 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 180518 if (curop->op_type == OP_GV) { 53012 GV *gv = cGVOPx_gv(curop); 53012 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) 45956 break; 45956 SvCUR_set(gv, PL_generation); } 127506 else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || curop->op_type == OP_PADANY) { 57295 if (PAD_COMPNAME_GEN(curop->op_targ) == (STRLEN)PL_generation) 2579 break; 54716 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation); } 70211 else if (curop->op_type == OP_RV2CV) 38 break; 70173 else if (curop->op_type == OP_RV2SV || curop->op_type == OP_RV2AV || curop->op_type == OP_RV2HV || curop->op_type == OP_RV2GV) { 55894 if (lastop->op_type != OP_GV) /* funny deref? */ 13119 break; } 14279 else if (curop->op_type == OP_PUSHRE) { 629 if (((PMOP*)curop)->op_pmreplroot) { #ifdef USE_ITHREADS GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET, ((PMOP*)curop)->op_pmreplroot)); #else 1 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; #endif 1 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) 1 break; 1 SvCUR_set(gv, PL_generation); } } else 1335005 break; } 1335005 lastop = curop; } 81945 if (curop != o) 36442 o->op_private |= OPpASSIGN_COMMON; } 199735 if (right && right->op_type == OP_SPLIT) { 4058 OP* tmpop; 4058 if ((tmpop = ((LISTOP*)right)->op_first) && tmpop->op_type == OP_PUSHRE) { 4058 PMOP *pm = (PMOP*)tmpop; 4058 if (left->op_type == OP_RV2AV && !(left->op_private & OPpLVAL_INTRO) && !(o->op_private & OPpASSIGN_COMMON) ) { 75 tmpop = ((UNOP*)left)->op_first; 75 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) { #ifdef USE_ITHREADS pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix); cPADOPx(tmpop)->op_padix = 0; /* steal it */ #else 74 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv; 74 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */ #endif 74 pm->op_pmflags |= PMf_ONCE; 74 tmpop = cUNOPo->op_first; /* to list (nulled) */ 74 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ 74 tmpop->op_sibling = Nullop; /* don't free split */ 74 right->op_next = tmpop->op_next; /* fix starting loc */ 74 op_free(o); /* blow off assign */ 74 right->op_flags &= ~OPf_WANT; /* "I don't know and I don't care." */ 74 return right; } } else { 3983 if (PL_modcount < RETURN_UNLIMITED_NUMBER && ((LISTOP*)right)->op_last->op_type == OP_CONST) { 592 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; 592 if (SvIVX(sv) == 0) 295 sv_setiv(sv, PL_modcount+1); } } } } 199661 return o; } 675767 if (!right) ###### right = newOP(OP_UNDEF, 0); 675767 if (right->op_type == OP_READLINE) { 2853 right->op_flags |= OPf_STACKED; 2853 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right)); } else { 672914 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ 672914 o = newBINOP(OP_SASSIGN, flags, scalar(right), mod(scalar(left), OP_SASSIGN) ); 672913 if (PL_eval_start) 672901 PL_eval_start = 0; else { 12 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase)); } } 672913 return o; } OP * Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) 2375353 { dVAR; 2375353 const U32 seq = intro_my(); 2375353 register COP *cop; 2375353 NewOp(1101, cop, 1, COP); 2375353 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) { 402 cop->op_type = OP_DBSTATE; 402 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ]; } else { 2374951 cop->op_type = OP_NEXTSTATE; 2374951 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; } 2375353 cop->op_flags = (U8)flags; 2375353 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif 2375353 PL_compiling.op_private = cop->op_private; 2375353 cop->op_next = (OP*)cop; 2375353 if (label) { 4297 cop->cop_label = label; 4297 PL_hints |= HINT_BLOCK_SCOPE; } 2375353 cop->cop_seq = seq; 2375353 cop->cop_arybase = PL_curcop->cop_arybase; 2375353 if (specialWARN(PL_curcop->cop_warnings)) 2340500 cop->cop_warnings = PL_curcop->cop_warnings ; else 34853 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ; 2375353 if (specialCopIO(PL_curcop->cop_io)) 2375327 cop->cop_io = PL_curcop->cop_io; else 26 cop->cop_io = newSVsv(PL_curcop->cop_io) ; 2375353 if (PL_copline == NOLINE) 114904 CopLINE_set(cop, CopLINE(PL_curcop)); else { 2260449 CopLINE_set(cop, PL_copline); 2260449 PL_copline = NOLINE; } #ifdef USE_ITHREADS CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ #else 2375353 CopFILEGV_set(cop, CopFILEGV(PL_curcop)); #endif 2375353 CopSTASH_set(cop, PL_curstash); 2375353 if (PERLDB_LINE && PL_curstash != PL_debstash) { 429 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE); 429 if (svp && *svp != &PL_sv_undef ) { 429 (void)SvIOK_on(*svp); 429 SvIV_set(*svp, PTR2IV(cop)); } } 2375353 return prepend_elem(OP_LINESEQ, (OP*)cop, o); } OP * Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) 567573 { dVAR; 567573 return new_logop(type, flags, &first, &other); } STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) 649993 { dVAR; 649993 LOGOP *logop; 649993 OP *o; 649993 OP *first = *firstp; 649993 OP *other = *otherp; 649993 if (type == OP_XOR) /* Not short circuit, but here by precedence. */ 1192 return newBINOP(type, flags, scalar(first), scalar(other)); 648801 scalarboolean(first); /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ 648801 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) { 21772 if (type == OP_AND || type == OP_OR) { 21772 if (type == OP_AND) 21772 type = OP_OR; else ###### type = OP_AND; 21772 o = first; 21772 first = *firstp = cUNOPo->op_first; 21772 if (o->op_next) 21772 first->op_next = o->op_next; 21772 cUNOPo->op_first = Nullop; 21772 op_free(o); } } 648801 if (first->op_type == OP_CONST) { 4446 if (first->op_private & OPpCONST_STRICT) 2 no_bareword_allowed(first); 4444 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) 1 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); 4446 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) || 57 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) || (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) { 1447 op_free(first); 1447 *firstp = Nullop; 1447 if (other->op_type == OP_CONST) 9 other->op_private |= OPpCONST_SHORTCIRCUIT; 1447 return other; } else { /* check for C, or C */ 2999 const OP *o2 = other; 2999 if ( ! (o2->op_type == OP_LIST && (( o2 = cUNOPx(o2)->op_first)) && o2->op_type == OP_PUSHMARK && (( o2 = o2->op_sibling)) ) ) 2998 o2 = other; 2999 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV || o2->op_type == OP_PADHV) && o2->op_private & OPpLVAL_INTRO && ckWARN(WARN_DEPRECATED)) { 7 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Deprecated use of my() in false conditional"); } 2999 op_free(other); 2999 *otherp = Nullop; 2999 if (first->op_type == OP_CONST) 2999 first->op_private |= OPpCONST_SHORTCIRCUIT; 2999 return first; } } 644355 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) && type != OP_DOR) /* [#24076] Don't warn for err FOO. */ { 247384 const OP *k1 = ((UNOP*)first)->op_first; 247384 const OP *k2 = k1->op_sibling; 247384 OPCODE warnop = 0; 247384 switch (first->op_type) { case OP_NULL: 52482 if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) { 1 warnop = k2->op_type; } 1 break; case OP_SASSIGN: 4239 if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH) { 5 warnop = ((k1->op_type == OP_NULL) ? (OPCODE)k1->op_targ : k1->op_type); } break; } 247384 if (warnop) { 6 const line_t oldline = CopLINE(PL_curcop); 6 CopLINE_set(PL_curcop, PL_copline); 6 Perl_warner(aTHX_ packWARN(WARN_MISC), "Value of %s%s can be \"0\"; test with defined()", PL_op_desc[warnop], ((warnop == OP_READLINE || warnop == OP_GLOB) ? " construct" : "() operator")); 6 CopLINE_set(PL_curcop, oldline); } } 644355 if (!other) ###### return first; 644355 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) 15720 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ 644355 NewOp(1101, logop, 1, LOGOP); 644355 logop->op_type = (OPCODE)type; 644355 logop->op_ppaddr = PL_ppaddr[type]; 644355 logop->op_first = first; 644355 logop->op_flags = flags | OPf_KIDS; 644355 logop->op_other = LINKLIST(other); 644355 logop->op_private = (U8)(1 | (flags >> 8)); /* establish postfix order */ 644355 logop->op_next = LINKLIST(first); 644355 first->op_next = (OP*)logop; 644355 first->op_sibling = other; 644355 CHECKOP(type,logop); 644349 o = newUNOP(OP_NULL, 0, (OP*)logop); 644349 other->op_next = o; 644349 return o; } OP * Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) 324804 { dVAR; 324804 LOGOP *logop; 324804 OP *start; 324804 OP *o; 324804 if (!falseop) 135103 return newLOGOP(OP_AND, 0, first, trueop); 189701 if (!trueop) ###### return newLOGOP(OP_OR, 0, first, falseop); 189701 scalarboolean(first); 189701 if (first->op_type == OP_CONST) { 327 if (first->op_private & OPpCONST_BARE && first->op_private & OPpCONST_STRICT) { 1 no_bareword_allowed(first); } 327 if (SvTRUE(((SVOP*)first)->op_sv)) { 259 op_free(first); 259 op_free(falseop); 259 return trueop; } else { 68 op_free(first); 68 op_free(trueop); 68 return falseop; } } 189374 NewOp(1101, logop, 1, LOGOP); 189374 logop->op_type = OP_COND_EXPR; 189374 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; 189374 logop->op_first = first; 189374 logop->op_flags = flags | OPf_KIDS; 189374 logop->op_private = (U8)(1 | (flags >> 8)); 189374 logop->op_other = LINKLIST(trueop); 189374 logop->op_next = LINKLIST(falseop); CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ 189374 logop); /* establish postfix order */ 189373 start = LINKLIST(first); 189373 first->op_next = (OP*)logop; 189373 first->op_sibling = trueop; 189373 trueop->op_sibling = falseop; 189373 o = newUNOP(OP_NULL, 0, (OP*)logop); 189373 trueop->op_next = falseop->op_next = o; 189373 o->op_next = start; 189373 return o; } OP * Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) 6051 { dVAR; 6051 LOGOP *range; 6051 OP *flip; 6051 OP *flop; 6051 OP *leftstart; 6051 OP *o; 6051 NewOp(1101, range, 1, LOGOP); 6051 range->op_type = OP_RANGE; 6051 range->op_ppaddr = PL_ppaddr[OP_RANGE]; 6051 range->op_first = left; 6051 range->op_flags = OPf_KIDS; 6051 leftstart = LINKLIST(left); 6051 range->op_other = LINKLIST(right); 6051 range->op_private = (U8)(1 | (flags >> 8)); 6051 left->op_sibling = right; 6051 range->op_next = (OP*)range; 6051 flip = newUNOP(OP_FLIP, flags, (OP*)range); 6050 flop = newUNOP(OP_FLOP, 0, flip); 6049 o = newUNOP(OP_NULL, 0, flop); 6049 linklist(flop); 6049 range->op_next = leftstart; 6049 left->op_next = flip; 6049 right->op_next = flop; 6049 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 6049 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); 6049 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 6049 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); 6049 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 6049 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 6049 flip->op_next = o; 6049 if (!flip->op_private || !flop->op_private) 4485 linklist(o); /* blow off optimizer unless constant */ 6049 return o; } OP * Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) 12822 { 12822 OP* listop; 12822 OP* o; 12822 const bool once = block && block->op_flags & OPf_SPECIAL && 12822 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); 12822 (void)debuggable; 12822 if (expr) { 12822 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) ###### return block; /* do {} while 0 does once */ 12822 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { 142 expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 12680 } else if (expr->op_flags & OPf_KIDS) { 12495 const OP *k1 = ((UNOP*)expr)->op_first; 12495 const OP *k2 = (k1) ? k1->op_sibling : NULL; 12495 switch (expr->op_type) { case OP_NULL: 575 if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 2 expr = newUNOP(OP_DEFINED, 0, expr); 2 break; case OP_SASSIGN: 38 if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH) 7 expr = newUNOP(OP_DEFINED, 0, expr); break; } } } /* if block is null, the next append_elem() would put UNSTACK, a scalar * op, in listop. This is wrong. [perl #27024] */ 12822 if (!block) ###### block = newOP(OP_NULL, 0); 12822 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); 12822 o = new_logop(OP_AND, 0, &expr, &listop); 12822 if (listop) 12822 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); 12822 if (once && o != listop) 940 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; 12822 if (o == listop) ###### o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ 12822 o->op_flags |= flags; 12822 o = scope(o); 12822 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ 12822 return o; } OP * Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont, I32 has_my) 81259 { dVAR; 81259 OP *redo; 81259 OP *next = 0; 81259 OP *listop; 81259 OP *o; 81259 U8 loopflags = 0; 81259 (void)debuggable; 81259 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { 1128 expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 80131 } else if (expr && (expr->op_flags & OPf_KIDS)) { 15357 const OP *k1 = ((UNOP*)expr)->op_first; 15357 const OP *k2 = (k1) ? k1->op_sibling : NULL; 15357 switch (expr->op_type) { ca