/* op.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was * our Mr. Bilbo's first cousin on the mother's side (her mother being the * youngest of the Old Took's daughters); and Mr. Drogo was his second * cousin. So Mr. Frodo is his first *and* second cousin, once removed * either way, as the saying is, if you follow me." --the Gaffer */ /* This file contains the functions that create, manipulate and optimize * the OP structures that hold a compiled perl program. * * A Perl program is compiled into a tree of OPs. Each op contains * structural pointers (eg to its siblings and the next op in the * execution sequence), a pointer to the function that would execute the * op, plus any data specific to that op. For example, an OP_CONST op * points to the pp_const() function and to an SV containing the constant * value. When pp_const() is executed, its job is to push that SV onto the * stack. * * OPs are mainly created by the newFOO() functions, which are mainly * called from the parser (in perly.y) as the code is parsed. For example * the Perl code $a + $b * $c would cause the equivalent of the following * to be called (oversimplifying a bit): * * newBINOP(OP_ADD, flags, * newSVREF($a), * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c)) * ) * * Note that during the build of miniperl, a temporary copy of this file * is made, called opmini.c. */ /* Perl's compiler is essentially a 3-pass compiler with interleaved phases: A bottom-up pass A top-down pass An execution-order pass The bottom-up pass is represented by all the "newOP" routines and the ck_ routines. The bottom-upness is actually driven by yacc. So at the point that a ck_ routine fires, we have no idea what the context is, either upward in the syntax tree, or either forward or backward in the execution order. (The bottom-up parser builds that part of the execution order it knows about, but if you follow the "next" links around, you'll find it's actually a closed loop through the top level node. Whenever the bottom-up parser gets to a node that supplies context to its components, it invokes that portion of the top-down pass that applies to that part of the subtree (and marks the top node as processed, so if a node further up supplies context, it doesn't have to take the plunge again). As a particular subcase of this, as the new node is built, it takes all the closed execution loops of its subcomponents and links them into a new closed loop for the higher level node. But it's still not the real execution order. The actual execution order is not known till we get a grammar reduction to a top-level unit like a subroutine or file that will be called by "name" rather than via a "next" pointer. At that point, we can call into peep() to do that code's portion of the 3rd pass. It has to be recursive, but it's recursive on basic blocks, not on tree nodes. */ #include "EXTERN.h" #define PERL_IN_OP_C #include "perl.h" #include "keywords.h" #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) #if defined(PL_OP_SLAB_ALLOC) #ifndef PERL_SLAB_SIZE #define PERL_SLAB_SIZE 2048 #endif void * Perl_Slab_Alloc(pTHX_ int m, size_t sz) { /* * To make incrementing use count easy PL_OpSlab is an I32 * * To make inserting the link to slab PL_OpPtr is I32 ** * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments * Add an overhead for pointer to slab and round up as a number of pointers */ sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *); if ((PL_OpSpace -= sz) < 0) { PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*)); if (!PL_OpPtr) { return NULL; } Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **); /* We reserve the 0'th I32 sized chunk as a use count */ PL_OpSlab = (I32 *) PL_OpPtr; /* Reduce size by the use count word, and by the size we need. * Latter is to mimic the '-=' in the if() above */ PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz; /* Allocation pointer starts at the top. Theory: because we build leaves before trunk allocating at end means that at run time access is cache friendly upward */ PL_OpPtr += PERL_SLAB_SIZE; } assert( PL_OpSpace >= 0 ); /* Move the allocation pointer down */ PL_OpPtr -= sz; assert( PL_OpPtr > (I32 **) PL_OpSlab ); *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */ (*PL_OpSlab)++; /* Increment use count of slab */ assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) ); assert( *PL_OpSlab > 0 ); return (void *)(PL_OpPtr + 1); } void Perl_Slab_Free(pTHX_ void *op) { I32 **ptr = (I32 **) op; I32 *slab = ptr[-1]; assert( ptr-1 > (I32 **) slab ); assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); assert( *slab > 0 ); if (--(*slab) == 0) { # ifdef NETWARE # define PerlMemShared PerlMem # endif PerlMemShared_free(slab); if (slab == PL_OpSlab) { PL_OpSpace = 0; } } } #endif /* * In the following definition, the ", Nullop" is just to make the compiler * think the expression is of the right type: croak actually does a Siglongjmp. */ #define CHECKOP(type,o) \ ((PL_op_mask && PL_op_mask[type]) \ ? ( op_free((OP*)o), \ Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ Nullop ) \ : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) STATIC const char* S_gv_ename(pTHX_ GV *gv) ###### { ###### SV* tmpsv = sv_newmortal(); ###### gv_efullname3(tmpsv, gv, Nullch); ###### return SvPV_nolen_const(tmpsv); } STATIC OP * S_no_fh_allowed(pTHX_ OP *o) ###### { ###### yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function", OP_DESC(o))); ###### return o; } STATIC OP * S_too_few_arguments(pTHX_ OP *o, const char *name) ###### { ###### yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name)); ###### return o; } STATIC OP * S_too_many_arguments(pTHX_ OP *o, const char *name) ###### { ###### yyerror(Perl_form(aTHX_ "Too many arguments for %s", name)); ###### return o; } STATIC void S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid) ###### { ###### yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", (int)n, name, t, OP_DESC(kid))); } STATIC void S_no_bareword_allowed(pTHX_ const OP *o) ###### { ###### qerror(Perl_mess(aTHX_ "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", cSVOPo_sv)); } /* "register" allocation */ PADOFFSET Perl_allocmy(pTHX_ char *name) 214565 { 214565 PADOFFSET off; /* complain about "my $" etc etc */ 214565 if (!(PL_in_my == KEY_our || isALPHA(name[1]) || (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) || (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2)))) { ###### if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { /* 1999-02-27 mjd@plover.com */ ###### char *p; ###### p = strchr(name, '\0'); /* The next block assumes the buffer is at least 205 chars long. At present, it's always at least 256 chars. */ ###### if (p-name > 200) { ###### strcpy(name+200, "..."); ###### p = name+199; } else { ###### p[1] = '\0'; } /* Move everything else down one character */ ###### for (; p-name > 2; p--) ###### *p = *(p-1); ###### name[2] = toCTRL(name[1]); ###### name[1] = '^'; } ###### yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name)); } /* check for duplicate declaration */ 214565 pad_check_dup(name, (bool)(PL_in_my == KEY_our), (PL_curstash ? PL_curstash : PL_defstash) ); 214565 if (PL_in_my_stash && *name != '$') { ###### yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"", name, PL_in_my == KEY_our ? "our" : "my")); } /* allocate a spare slot and store the name in that slot */ 214565 off = pad_add_name(name, PL_in_my_stash, (PL_in_my == KEY_our /* $_ is always in main::, even with our */ ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) : Nullhv ), 0 /* not fake */ ); 214565 return off; } /* Destructor */ void Perl_op_free(pTHX_ OP *o) 8496069 { dVAR; 8496069 OPCODE type; 8496069 PADOFFSET refcnt; 8496069 if (!o || o->op_static) 8477959 return; 8477959 if (o->op_private & OPpREFCOUNTED) { 508618 switch (o->op_type) { case OP_LEAVESUB: case OP_LEAVESUBLV: case OP_LEAVEEVAL: case OP_LEAVE: case OP_SCOPE: case OP_LEAVEWRITE: 102500 OP_REFCNT_LOCK; 102500 refcnt = OpREFCNT_dec(o); 102500 OP_REFCNT_UNLOCK; 102500 if (refcnt) 2948 return; 8475011 break; default: 8475011 break; } } 8475011 if (o->op_flags & OPf_KIDS) { 3855089 register OP *kid, *nextkid; 11800215 for (kid = cUNOPo->op_first; kid; kid = nextkid) { 7945126 nextkid = kid->op_sibling; /* Get before next freeing kid */ 7945126 op_free(kid); } } 8475011 type = o->op_type; 8475011 if (type == OP_NULL) 1439759 type = (OPCODE)o->op_targ; /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ 8475011 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) 830221 cop_free((COP*)o); 8475011 op_clear(o); 8475011 FreeOp(o); #ifdef DEBUG_LEAKING_SCALARS if (PL_op == o) PL_op = Nullop; #endif } void Perl_op_clear(pTHX_ OP *o) 9545920 { dVAR; 9545920 switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ case OP_ENTEREVAL: /* Was holding hints. */ 1445689 o->op_targ = 0; 1445689 break; default: 6185245 if (!(o->op_flags & OPf_REF) || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst))) 539497 break; /* FALL THROUGH */ case OP_GVSV: case OP_GV: case OP_AELEMFAST: 539497 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) { /* not an OP_PADAV replacement */ #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { /* No GvIN_PAD_off(cGVOPo_gv) here, because other references * may still exist on the pad */ pad_swipe(cPADOPo->op_padix, TRUE); cPADOPo->op_padix = 0; } #else 533191 SvREFCNT_dec(cSVOPo->op_sv); 533191 cSVOPo->op_sv = Nullsv; #endif } 533191 break; case OP_METHOD_NAMED: case OP_CONST: 1273570 SvREFCNT_dec(cSVOPo->op_sv); 1273570 cSVOPo->op_sv = Nullsv; #ifdef USE_ITHREADS /** Bug #15654 Even if op_clear does a pad_free for the target of the op, pad_free doesn't actually remove the sv that exists in the pad; instead it lives on. This results in that it could be reused as a target later on when the pad was reallocated. **/ if(o->op_targ) { pad_swipe(o->op_targ,1); o->op_targ = 0; } #endif 1273570 break; case OP_GOTO: case OP_NEXT: case OP_LAST: case OP_REDO: 34124 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) 26735 break; /* FALL THROUGH */ case OP_TRANS: 8706 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { ###### SvREFCNT_dec(cSVOPo->op_sv); ###### cSVOPo->op_sv = Nullsv; } else { 8706 Safefree(cPVOPo->op_pv); 8706 cPVOPo->op_pv = Nullch; } 8706 break; case OP_SUBST: 24068 op_free(cPMOPo->op_pmreplroot); 24068 goto clear_pmop; case OP_PUSHRE: #ifdef USE_ITHREADS if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) { /* No GvIN_PAD_off here, because other references may still * exist on the pad */ pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE); } #else 4498 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot); #endif /* FALL THROUGH */ case OP_MATCH: case OP_QR: clear_pmop: { 70148 HV *pmstash = PmopSTASH(cPMOPo); 70148 if (pmstash && SvREFCNT(pmstash)) { 61277 MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); 61277 if (mg) { 61277 PMOP *pmop = (PMOP*) mg->mg_obj; 61277 PMOP *lastpmop = NULL; 533326 while (pmop) { 533326 if (cPMOPo == pmop) { 61277 if (lastpmop) 51093 lastpmop->op_pmnext = pmop->op_pmnext; else 10184 mg->mg_obj = (SV*) pmop->op_pmnext; 10184 break; } 472049 lastpmop = pmop; 472049 pmop = pmop->op_pmnext; } } } PmopSTASH_free(cPMOPo); } 70148 cPMOPo->op_pmreplroot = Nullop; /* we use the "SAFE" version of the PM_ macros here * since sv_clean_all might release some PMOPs * after PL_regex_padav has been cleared * and the clearing of PL_regex_padav needs to * happen before sv_clean_all */ 70148 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo)); 70148 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL); #ifdef USE_ITHREADS if(PL_regex_pad) { /* We could be in destruction */ av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]); SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]); PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset); } #endif 9545920 break; } 9545920 if (o->op_targ > 0) { 1897618 pad_free(o->op_targ); 1897618 o->op_targ = 0; } } STATIC void S_cop_free(pTHX_ COP* cop) 830221 { 830221 Safefree(cop->cop_label); /* FIXME: treaddead ??? */ 830221 CopFILE_free(cop); CopSTASH_free(cop); 830221 if (! specialWARN(cop->cop_warnings)) 182 SvREFCNT_dec(cop->cop_warnings); 830221 if (! specialCopIO(cop->cop_io)) { #ifdef USE_ITHREADS #if 0 STRLEN len; char *s = SvPV(cop->cop_io,len); Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */ #endif #else ###### SvREFCNT_dec(cop->cop_io); #endif } } void Perl_op_null(pTHX_ OP *o) 1070909 { dVAR; 1070909 if (o->op_type == OP_NULL) ###### return; 1070909 op_clear(o); 1070909 o->op_targ = o->op_type; 1070909 o->op_type = OP_NULL; 1070909 o->op_ppaddr = PL_ppaddr[OP_NULL]; } void Perl_op_refcnt_lock(pTHX) ###### { dVAR; ###### OP_REFCNT_LOCK; } void Perl_op_refcnt_unlock(pTHX) ###### { dVAR; ###### OP_REFCNT_UNLOCK; } /* Contextualizers */ #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) OP * Perl_linklist(pTHX_ OP *o) 3362819 { 3362819 if (o->op_next) 8668 return o->op_next; /* establish postfix order */ 3354151 if (cUNOPo->op_first) { 3341852 register OP *kid; 3341852 o->op_next = LINKLIST(cUNOPo->op_first); 10381749 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 7039897 if (kid->op_sibling) 3698045 kid->op_next = LINKLIST(kid->op_sibling); else 3341852 kid->op_next = o; } } else 12299 o->op_next = o; 3354151 return o->op_next; } OP * Perl_scalarkids(pTHX_ OP *o) 1655 { 1655 if (o && o->op_flags & OPf_KIDS) { 1655 OP *kid; 3868 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 2213 scalar(kid); } 1655 return o; } STATIC OP * S_scalarboolean(pTHX_ OP *o) 343036 { 343036 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { ###### if (ckWARN(WARN_SYNTAX)) { ###### const line_t oldline = CopLINE(PL_curcop); ###### if (PL_copline != NOLINE) ###### CopLINE_set(PL_curcop, PL_copline); ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); ###### CopLINE_set(PL_curcop, oldline); } } 343036 return scalar(o); } OP * Perl_scalar(pTHX_ OP *o) 11559336 { dVAR; 11559336 OP *kid; /* assumes no premature commitment */ 11559336 if (!o || (o->op_flags & OPf_WANT) || PL_error_count || o->op_type == OP_RETURN) { 6093061 return o; } 5466275 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; 5466275 switch (o->op_type) { case OP_REPEAT: 286 scalar(cBINOPo->op_first); 286 break; case OP_OR: case OP_AND: case OP_COND_EXPR: 187706 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 101502 scalar(kid); ###### break; case OP_SPLIT: ###### if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { ###### if (!kPMOP->op_pmreplroot) ###### deprecate_old("implicit split to @_"); } /* FALL THROUGH */ case OP_MATCH: case OP_QR: case OP_SUBST: case OP_NULL: default: 5314387 if (o->op_flags & OPf_KIDS) { 5164742 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 3182697 scalar(kid); } 3174 break; case OP_LEAVE: case OP_LEAVETRY: 3174 kid = cLISTOPo->op_first; 3174 scalar(kid); 12376 while ((kid = kid->op_sibling)) { 9202 if (kid->op_sibling) 6028 scalarvoid(kid); else 3174 scalar(kid); } 3174 WITH_THR(PL_curcop = &PL_compiling); 3174 break; case OP_SCOPE: case OP_LINESEQ: case OP_LIST: 419064 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 356840 if (kid->op_sibling) 294616 scalarvoid(kid); else 62224 scalar(kid); } 62224 WITH_THR(PL_curcop = &PL_compiling); 62224 break; case OP_SORT: ###### if (ckWARN(WARN_VOID)) ###### Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); } 5466275 return o; } OP * Perl_scalarvoid(pTHX_ OP *o) 3595521 { dVAR; 3595521 OP *kid; 3595521 const char* useless = 0; 3595521 SV* sv; 3595521 U8 want; 3595521 if (o->op_type == OP_NEXTSTATE || o->op_type == OP_SETSTATE || o->op_type == OP_DBSTATE || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_SETSTATE || o->op_targ == OP_DBSTATE))) 1632354 PL_curcop = (COP*)o; /* for warning below */ /* assumes no premature commitment */ 3595521 want = o->op_flags & OPf_WANT; 3595521 if ((want && want != OPf_WANT_SCALAR) || PL_error_count || o->op_type == OP_RETURN) { 1387323 return o; } 2208198 if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { 9982 return scalar(o); /* As if inside SASSIGN */ } 2198216 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 2198216 switch (o->op_type) { default: 493868 if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) 475021 break; /* FALL THROUGH */ case OP_REPEAT: 18847 if (o->op_flags & OPf_STACKED) 18847 break; ###### goto func_ops; case OP_SUBSTR: ###### if (o->op_private == 4) ###### break; /* FALL THROUGH */ case OP_GVSV: case OP_WANTARRAY: case OP_GV: case OP_PADSV: case OP_PADAV: case OP_PADHV: case OP_PADANY: case OP_AV2ARYLEN: case OP_REF: case OP_REFGEN: case OP_SREFGEN: case OP_DEFINED: case OP_HEX: case OP_OCT: case OP_LENGTH: case OP_VEC: case OP_INDEX: case OP_RINDEX: case OP_SPRINTF: case OP_AELEM: case OP_AELEMFAST: case OP_ASLICE: case OP_HELEM: case OP_HSLICE: case OP_UNPACK: case OP_PACK: case OP_JOIN: case OP_LSLICE: case OP_ANONLIST: case OP_ANONHASH: case OP_SORT: case OP_REVERSE: case OP_RANGE: case OP_FLIP: case OP_FLOP: case OP_CALLER: case OP_FILENO: case OP_EOF: case OP_TELL: case OP_GETSOCKNAME: case OP_GETPEERNAME: case OP_READLINK: case OP_TELLDIR: case OP_GETPPID: case OP_GETPGRP: case OP_GETPRIORITY: case OP_TIME: case OP_TMS: case OP_LOCALTIME: case OP_GMTIME: case OP_GHBYNAME: case OP_GHBYADDR: case OP_GHOSTENT: case OP_GNBYNAME: case OP_GNBYADDR: case OP_GNETENT: case OP_GPBYNAME: case OP_GPBYNUMBER: case OP_GPROTOENT: case OP_GSBYNAME: case OP_GSBYPORT: case OP_GSERVENT: case OP_GPWNAM: case OP_GPWUID: case OP_GGRNAM: case OP_GGRGID: case OP_GETLOGIN: case OP_PROTOTYPE: func_ops: 40460 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) ###### useless = OP_DESC(o); ###### break; case OP_NOT: ###### kid = cUNOPo->op_first; ###### if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && kid->op_type != OP_TRANS) { ###### goto func_ops; } ###### useless = "negative pattern binding (!~)"; ###### break; case OP_RV2GV: case OP_RV2SV: case OP_RV2AV: case OP_RV2HV: 17489 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) ###### useless = "a variable"; ###### break; case OP_CONST: 143 sv = cSVOPo_sv; 143 if (cSVOPo->op_private & OPpCONST_STRICT) ###### no_bareword_allowed(o); else { 143 if (ckWARN(WARN_VOID)) { 59 useless = "a constant"; /* don't warn on optimised away booleans, eg * use constant Foo, 5; Foo || print; */ 59 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) 1 useless = 0; /* the constants 0 and 1 are permitted as they are conventionally used as dummies in constructs like 1 while some_condition_with_side_effects; */ 58 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) 58 useless = 0; ###### else if (SvPOK(sv)) { /* perl4's way of mixing documentation and code (before the invention of POD) was based on a trick to mix nroff and perl code. The trick was built upon these three nroff macros being used in void context. The pink camel has the details in the script wrapman near page 319. */ ###### if (strnEQ(SvPVX_const(sv), "di", 2) || strnEQ(SvPVX_const(sv), "ds", 2) || strnEQ(SvPVX_const(sv), "ig", 2)) ###### useless = 0; } } } 143 op_null(o); /* don't execute or even remember it */ 143 break; case OP_POSTINC: 3860 o->op_type = OP_PREINC; /* pre-increment is faster */ 3860 o->op_ppaddr = PL_ppaddr[OP_PREINC]; 3860 break; case OP_POSTDEC: 57 o->op_type = OP_PREDEC; /* pre-decrement is faster */ 57 o->op_ppaddr = PL_ppaddr[OP_PREDEC]; 57 break; case OP_OR: case OP_AND: case OP_DOR: case OP_COND_EXPR: 500899 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 272583 scalarvoid(kid); 239033 break; case OP_NULL: 239033 if (o->op_flags & OPf_STACKED) 1144 break; /* FALL THROUGH */ case OP_NEXTSTATE: case OP_DBSTATE: case OP_ENTERTRY: case OP_ENTER: 1146787 if (!(o->op_flags & OPf_KIDS)) 908898 break; /* FALL THROUGH */ case OP_SCOPE: case OP_LEAVE: case OP_LEAVETRY: case OP_LEAVELOOP: case OP_LINESEQ: case OP_LIST: 1557553 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1122992 scalarvoid(kid); 1376 break; case OP_ENTEREVAL: 1376 scalarkids(o); 1376 break; case OP_REQUIRE: /* all requires must return a boolean value */ 68040 o->op_flags &= ~OPf_WANT; /* FALL THROUGH */ case OP_SCALAR: 68040 return scalar(o); case OP_SPLIT: 4 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { 4 if (!kPMOP->op_pmreplroot) 1 deprecate_old("implicit split to @_"); } 2130176 break; } 2130176 if (useless && ckWARN(WARN_VOID)) ###### Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless); 2130176 return o; } OP * Perl_listkids(pTHX_ OP *o) 1000802 { 1000802 if (o && o->op_flags & OPf_KIDS) { 1000802 OP *kid; 3095875 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 2095073 list(kid); } 1000802 return o; } OP * Perl_list(pTHX_ OP *o) 2558464 { dVAR; 2558464 OP *kid; /* assumes no premature commitment */ 2558464 if (!o || (o->op_flags & OPf_WANT) || PL_error_count || o->op_type == OP_RETURN) { 1820523 return o; } 737941 if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { ###### return o; /* As if inside SASSIGN */ } 737941 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; 737941 switch (o->op_type) { case OP_FLOP: case OP_REPEAT: 1796 list(cBINOPo->op_first); 1796 break; case OP_OR: case OP_AND: case OP_COND_EXPR: 15451 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 10081 list(kid); 719009 break; default: case OP_MATCH: case OP_QR: case OP_SUBST: case OP_NULL: 719009 if (!(o->op_flags & OPf_KIDS)) 236331 break; 482678 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) { 178 list(cBINOPo->op_first); 178 return gen_constant_list(o); } case OP_LIST: 489519 listkids(o); 489519 break; case OP_LEAVE: case OP_LEAVETRY: 2291 kid = cLISTOPo->op_first; 2291 list(kid); 8151 while ((kid = kid->op_sibling)) { 5860 if (kid->op_sibling) 3569 scalarvoid(kid); else 2291 list(kid); } 2291 WITH_THR(PL_curcop = &PL_compiling); 2291 break; case OP_SCOPE: case OP_LINESEQ: 7368 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 4912 if (kid->op_sibling) 2456 scalarvoid(kid); else 2456 list(kid); } 2456 WITH_THR(PL_curcop = &PL_compiling); 2456 break; case OP_REQUIRE: /* all requires must return a boolean value */ ###### o->op_flags &= ~OPf_WANT; ###### return scalar(o); } 737763 return o; } OP * Perl_scalarseq(pTHX_ OP *o) 463400 { 463400 if (o) { 461737 if (o->op_type == OP_LINESEQ || o->op_type == OP_SCOPE || o->op_type == OP_LEAVE || o->op_type == OP_LEAVETRY) { 379131 OP *kid; 2649869 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 2270738 if (kid->op_sibling) { 1891607 scalarvoid(kid); } } 379131 PL_curcop = &PL_compiling; } 461737 o->op_flags &= ~OPf_PARENS; 461737 if (PL_hints & HINT_BLOCK_SCOPE) 364000 o->op_flags |= OPf_PARENS; } else 1663 o = newOP(OP_STUB, 0); 463400 return o; } STATIC OP * S_modkids(pTHX_ OP *o, I32 type) 86753 { 86753 if (o && o->op_flags & OPf_KIDS) { 80499 OP *kid; 160998 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 80499 mod(kid, type); } 86753 return o; } /* Propagate lvalue ("modifiable") context to an op and it's children. * 'type' represents the context type, roughly based on the type of op that * would do the modifying, although local() is represented by OP_NULL. * It's responsible for detecting things that can't be modified, flag * things that need to behave specially in an lvalue context (e.g., "$$x = 5" * might have to vivify a reference in $x), and so on. * * For example, "$a+1 = 2" would cause mod() to be called with o being * OP_ADD and type being OP_SASSIGN, and would output an error. */ OP * Perl_mod(pTHX_ OP *o, I32 type) 1049380 { dVAR; 1049380 OP *kid; /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ 1049380 int localize = -1; 1049380 if (!o || PL_error_count) 34 return o; 1049346 if ((o->op_private & OPpTARGET_MY) && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { 42 return o; } 1049304 switch (o->op_type) { case OP_UNDEF: 978 localize = 0; 978 PL_modcount++; 978 return o; case OP_CONST: 88811 if (!(o->op_private & (OPpCONST_ARYBASE))) 88811 goto nomod; ###### if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { ###### PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv); ###### PL_eval_start = 0; } ###### else if (!type) { ###### SAVEI32(PL_compiling.cop_arybase); ###### PL_compiling.cop_arybase = 0; } ###### else if (type == OP_REFGEN) ###### goto nomod; else ###### Perl_croak(aTHX_ "That use of $[ is unsupported"); 622 break; case OP_STUB: 622 if (o->op_flags & OPf_PARENS) 622 break; 20076 goto nomod; case OP_ENTERSUB: 20076 if ((type == OP_UNDEF || type == OP_REFGEN) && !(o->op_flags & OPf_STACKED)) { 17027 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 17027 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 17027 assert(cUNOPo->op_first->op_type == OP_NULL); 17027 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ 17027 break; } 3049 else if (o->op_private & OPpENTERSUB_NOMOD) ###### return o; else { /* lvalue subroutine call */ 3049 o->op_private |= OPpLVAL_INTRO; 3049 PL_modcount = RETURN_UNLIMITED_NUMBER; 3049 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { /* Backward compatibility mode: */ 3049 o->op_private |= OPpENTERSUB_INARGS; 3049 break; } else { /* Compile-time error message: */ ###### OP *kid = cUNOPo->op_first; ###### CV *cv; ###### OP *okid; ###### if (kid->op_type == OP_PUSHMARK) ###### goto skip_kids; ###### if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) ###### Perl_croak(aTHX_ "panic: unexpected lvalue entersub " "args: type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); ###### kid = kLISTOP->op_first; skip_kids: ###### while (kid->op_sibling) ###### kid = kid->op_sibling; ###### if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { /* Indirect call */ ###### if (kid->op_type == OP_METHOD_NAMED || kid->op_type == OP_METHOD) { ###### UNOP *newop; ###### NewOp(1101, newop, 1, UNOP); ###### newop->op_type = OP_RV2CV; ###### newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; ###### newop->op_first = Nullop; ###### newop->op_next = (OP*)newop; ###### kid->op_sibling = (OP*)newop; ###### newop->op_private |= OPpLVAL_INTRO; ###### break; } ###### if (kid->op_type != OP_RV2CV) ###### Perl_croak(aTHX_ "panic: unexpected lvalue entersub " "entry via type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); ###### kid->op_private |= OPpLVAL_INTRO; ###### break; /* Postpone until runtime */ } ###### okid = kid; ###### kid = kUNOP->op_first; ###### if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) ###### kid = kUNOP->op_first; ###### if (kid->op_type == OP_NULL) ###### Perl_croak(aTHX_ "Unexpected constant lvalue entersub " "entry via type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); ###### if (kid->op_type != OP_GV) { /* Restore RV2CV to check lvalueness */ restore_2cv: ###### if (kid->op_next && kid->op_next != kid) { /* Happens? */ ###### okid->op_next = kid->op_next; ###### kid->op_next = okid; } else ###### okid->op_next = Nullop; ###### okid->op_type = OP_RV2CV; ###### okid->op_targ = 0; ###### okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; ###### okid->op_private |= OPpLVAL_INTRO; ###### break; } ###### cv = GvCV(kGVOP_gv); ###### if (!cv) ###### goto restore_2cv; ###### if (CvLVALUE(cv)) ###### break; } } /* FALL THROUGH */ default: nomod: /* grep, foreach, subcalls, refgen */ 166892 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) ###### break; ###### yyerror(Perl_form(aTHX_ "Can't modify %s in %s", (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) ? "do block" : (o->op_type == OP_ENTERSUB ? "non-lvalue subroutine call" : OP_DESC(o))), type ? PL_op_desc[type] : "local")); ###### return o; case OP_PREINC: case OP_PREDEC: case OP_POW: case OP_MULTIPLY: case OP_DIVIDE: case OP_MODULO: case OP_REPEAT: case OP_ADD: case OP_SUBTRACT: case OP_CONCAT: case OP_LEFT_SHIFT: case OP_RIGHT_SHIFT: case OP_BIT_AND: case OP_BIT_XOR: case OP_BIT_OR: case OP_I_MULTIPLY: case OP_I_DIVIDE: case OP_I_MODULO: case OP_I_ADD: case OP_I_SUBTRACT: 2599 if (!(o->op_flags & OPf_STACKED)) 1491 goto nomod; 1108 PL_modcount++; 1108 break; case OP_COND_EXPR: 1395 localize = 1; 4185 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 2790 mod(kid, type); 110130 break; case OP_RV2AV: case OP_RV2HV: 110130 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { 50 PL_modcount = RETURN_UNLIMITED_NUMBER; 50 return o; /* Treat \(@foo) like ordinary list. */ } /* FALL THROUGH */ case OP_RV2GV: 128856 if (scalar_mod_type(o, type)) ###### goto nomod; 128856 ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_ASLICE: case OP_HSLICE: 131366 if (type == OP_LEAVESUBLV) ###### o->op_private |= OPpMAYBE_LVSUB; 131366 localize = 1; /* FALL THROUGH */ case OP_AASSIGN: case OP_NEXTSTATE: case OP_DBSTATE: 131392 PL_modcount = RETURN_UNLIMITED_NUMBER; 131392 break; case OP_RV2SV: 76120 ref(cUNOPo->op_first, o->op_type); 76120 localize = 1; /* FALL THROUGH */ case OP_GV: case OP_AV2ARYLEN: 76282 PL_hints |= HINT_BLOCK_SCOPE; case OP_SASSIGN: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: 78282 PL_modcount++; 78282 break; case OP_AELEMFAST: ###### localize = -1; ###### PL_modcount++; ###### break; case OP_PADAV: case OP_PADHV: 57896 PL_modcount = RETURN_UNLIMITED_NUMBER; 57896 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) ###### return o; /* Treat \(@foo) like ordinary list. */ 57896 if (scalar_mod_type(o, type)) ###### goto nomod; 57896 if (type == OP_LEAVESUBLV) ###### o->op_private |= OPpMAYBE_LVSUB; /* FALL THROUGH */ case OP_PADSV: 408712 PL_modcount++; 408712 if (!type) /* local() */ ###### Perl_croak(aTHX_ "Can't localize lexical variable %s", PAD_COMPNAME_PV(o->op_targ)); 97343 break; case OP_PUSHMARK: 97343 localize = 0; 97343 break; case OP_KEYS: 1867 if (type != OP_SASSIGN) 1867 goto nomod; 482 goto lvalue_func; case OP_SUBSTR: 482 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ ###### goto nomod; /* FALL THROUGH */ case OP_POS: case OP_VEC: 2886 if (type == OP_LEAVESUBLV) ###### o->op_private |= OPpMAYBE_LVSUB; lvalue_func: 2886 pad_free(o->op_targ); 2886 o->op_targ = pad_alloc(o->op_type, SVs_PADMY); 2886 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL); 2886 if (o->op_flags & OPf_KIDS) 2886 mod(cBINOPo->op_first->op_sibling, type); 2886 break; case OP_AELEM: case OP_HELEM: 40722 ref(cBINOPo->op_first, o->op_type); 40722 if (type == OP_ENTERSUB && !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) 4894 o->op_private |= OPpLVAL_DEFER; 40722 if (type == OP_LEAVESUBLV) ###### o->op_private |= OPpMAYBE_LVSUB; 40722 localize = 1; 40722 PL_modcount++; 40722 break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: case OP_LINESEQ: ###### localize = 0; ###### if (o->op_flags & OPf_KIDS) ###### mod(cLISTOPo->op_last, type); ###### break; case OP_NULL: 66620 localize = 0; 66620 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ 1320 goto nomod; 65300 else if (!(o->op_flags & OPf_KIDS)) ###### break; 65300 if (o->op_targ != OP_LIST) { 1503 mod(cBINOPo->op_first, type); 1503 break; } /* FALL THROUGH */ case OP_LIST: 97343 localize = 0; 351236 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 253893 mod(kid, type); ###### break; case OP_RETURN: ###### if (type != OP_LEAVESUBLV) ###### goto nomod; 1048276 break; /* mod()ing was handled by ck_return() */ } /* [20011101.069] File test operators interpret OPf_REF to mean that their argument is a filehandle; thus \stat(".") should not set it. AMS 20011102 */ 1048276 if (type == OP_REFGEN && PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)) ###### return o; 1048276 if (type != OP_LEAVESUBLV) 1048276 o->op_flags |= OPf_MOD; 1048276 if (type == OP_AASSIGN || type == OP_SASSIGN) 400656 o->op_flags |= OPf_SPECIAL|OPf_REF; 647620 else if (!type) { /* local() */ 21888 switch (localize) { case 1: 17736 o->op_private |= OPpLVAL_INTRO; 17736 o->op_flags &= ~OPf_SPECIAL; 17736 PL_hints |= HINT_BLOCK_SCOPE; 17736 break; case 0: ###### break; case -1: ###### if (ckWARN(WARN_SYNTAX)) { ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Useless localization of %s", OP_DESC(o)); } } } 625732 else if (type != OP_GREPSTART && type != OP_ENTERSUB && type != OP_LEAVESUBLV) 329440 o->op_flags |= OPf_REF; 1048276 return o; } STATIC bool S_scalar_mod_type(pTHX_ const OP *o, I32 type) 186752 { 186752 switch (type) { case OP_SASSIGN: 12780 if (o->op_type == OP_RV2GV) 12780 return FALSE; /* FALL THROUGH */ case OP_PREINC: case OP_PREDEC: case OP_POSTINC: case OP_POSTDEC: case OP_I_PREINC: case OP_I_PREDEC: case OP_I_POSTINC: case OP_I_POSTDEC: case OP_POW: case OP_MULTIPLY: case OP_DIVIDE: case OP_MODULO: case OP_REPEAT: case OP_ADD: case OP_SUBTRACT: case OP_I_MULTIPLY: case OP_I_DIVIDE: case OP_I_MODULO: case OP_I_ADD: case OP_I_SUBTRACT: case OP_LEFT_SHIFT: case OP_RIGHT_SHIFT: case OP_BIT_AND: case OP_BIT_XOR: case OP_BIT_OR: case OP_CONCAT: case OP_SUBST: case OP_TRANS: case OP_READ: case OP_SYSREAD: case OP_RECV: case OP_ANDASSIGN: case OP_ORASSIGN: ###### return TRUE; default: 173972 return FALSE; } } STATIC bool S_is_handle_constructor(pTHX_ const OP *o, I32 numargs) 6242 { 6242 switch (o->op_type) { case OP_PIPE_OP: case OP_SOCKPAIR: ###### if (numargs == 2) ###### return TRUE; /* FALL THROUGH */ case OP_SYSOPEN: case OP_OPEN: case OP_SELECT: /* XXX c.f. SelectSaver.pm */ case OP_SOCKET: case OP_OPEN_DIR: case OP_ACCEPT: 1856 if (numargs == 1) 1856 return TRUE; /* FALL THROUGH */ default: 4386 return FALSE; } } OP * Perl_refkids(pTHX_ OP *o, I32 type) 35094 { 35094 if (o && o->op_flags & OPf_KIDS) { 35094 OP *kid; 70188 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 35094 ref(kid, type); } 35094 return o; } OP * Perl_ref(pTHX_ OP *o, I32 type) 699988 { dVAR; 699988 OP *kid; 699988 if (!o || PL_error_count) ###### return o; 699988 switch (o->op_type) { case OP_ENTERSUB: 4634 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { 4466 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 4466 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 4466 assert(cUNOPo->op_first->op_type == OP_NULL); 4466 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ 4466 o->op_flags |= OPf_SPECIAL; } 4466 break; case OP_COND_EXPR: ###### for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) ###### ref(kid, type); 4650 break; case OP_RV2SV: 4650 if (type == OP_DEFINED) 4217 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 4650 ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_PADSV: 107892 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 76385 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : type == OP_RV2HV ? OPpDEREF_HV : OPpDEREF_SV); 76385 o->op_flags |= OPf_MOD; } 76385 break; case OP_THREADSV: ###### o->op_flags |= OPf_MOD; /* XXX ??? */ ###### break; case OP_RV2AV: case OP_RV2HV: 165181 o->op_flags |= OPf_REF; /* FALL THROUGH */ case OP_RV2GV: 192014 if (type == OP_DEFINED) ###### o->op_flags |= OPf_SPECIAL; /* don't create GV */ 192014 ref(cUNOPo->op_first, o->op_type); 192014 break; case OP_PADAV: case OP_PADHV: 46766 o->op_flags |= OPf_REF; 46766 break; case OP_SCALAR: case OP_NULL: 2675 if (!(o->op_flags & OPf_KIDS)) ###### break; 2675 ref(cBINOPo->op_first, type); 2675 break; case OP_AELEM: case OP_HELEM: 15843 ref(cBINOPo->op_first, o->op_type); 15843 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 11097 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : type == OP_RV2HV ? OPpDEREF_HV : OPpDEREF_SV); 11097 o->op_flags |= OPf_MOD; } 11097 break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: case OP_LIST: 21800 if (!(o->op_flags & OPf_KIDS)) ###### break; 21800 ref(cLISTOPo->op_last, type); break; default: 699988 break; } 699988 return scalar(o); } STATIC OP * S_dup_attrlist(pTHX_ OP *o) ###### { ###### OP *rop = Nullop; /* An attrlist is either a simple OP_CONST or an OP_LIST with kids, * where the first kid is OP_PUSHMARK and the remaining ones * are OP_CONST. We need to push the OP_CONST values. */ ###### if (o->op_type == OP_CONST) ###### rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv)); else { ###### assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); ###### for (o = cLISTOPo->op_first; o; o=o->op_sibling) { ###### if (o->op_type == OP_CONST) ###### rop = append_elem(OP_LIST, rop, newSVOP(OP_CONST, o->op_flags, ###### SvREFCNT_inc(cSVOPo->op_sv))); } } ###### return rop; } STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) ###### { dVAR; ###### SV *stashsv; /* fake up C */ ###### ENTER; /* need to protect against side-effects of 'use' */ ###### SAVEINT(PL_expect); ###### stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; #define ATTRSMODULE "attributes" #define ATTRSMODULE_PM "attributes.pm" ###### if (for_my) { /* Don't force the C if we don't need it. */ ###### SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, ###### sizeof(ATTRSMODULE_PM)-1, 0); ###### if (svp && *svp != &PL_sv_undef) ; /* already in %INC */ else ###### Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), Nullsv); } else { ###### Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), Nullsv, prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, stashsv), prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newRV(target)), dup_attrlist(attrs)))); } ###### LEAVE; } STATIC void S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) ###### { ###### OP *pack, *imop, *arg; ###### SV *meth, *stashsv; ###### if (!attrs) ###### return; assert(target->op_type == OP_PADSV || target->op_type == OP_PADHV || ###### target->op_type == OP_PADAV); /* Ensure that attributes.pm is loaded. */ ###### apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE); /* Need package name for method call. */ ###### pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); /* Build up the real arg-list. */ ###### stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; ###### arg = newOP(OP_PADSV, 0); ###### arg->op_targ = target->op_targ; ###### arg = prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, stashsv), prepend_elem(OP_LIST, newUNOP(OP_REFGEN, 0, mod(arg, OP_REFGEN)), dup_attrlist(attrs))); /* Fake up a method call to import */ ###### meth = newSVpvn_share("import", 6, 0); ###### imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(arg)), newSVOP(OP_METHOD_NAMED, 0, meth))); ###### imop->op_private |= OPpENTERSUB_NOMOD; /* Combine the ops. */ ###### *imopsp = append_elem(OP_LIST, *imopsp, imop); } /* =notfor apidoc apply_attrs_string Attempts to apply a list of attributes specified by the C and C arguments to the subroutine identified by the C argument which is expected to be associated with the package identified by the C argument (see L). It gets this wrong, though, in that it does not correctly identify the boundaries of the individual attribute specifications within C. This is not really intended for the public API, but has to be listed here for systems such as AIX which need an explicit export list for symbols. (It's called from XS code in support of the C keyword from F.) Patches to fix it to respect attribute syntax properly would be welcome. =cut */ void Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, const char *attrstr, STRLEN len) ###### { ###### OP *attrs = Nullop; ###### if (!len) { ###### len = strlen(attrstr); } ###### while (len) { ###### for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; ###### if (len) { ###### const char *sstr = attrstr; ###### for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; ###### attrs = append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, newSVpvn(sstr, attrstr-sstr))); } } ###### Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), Nullsv, prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newRV((SV*)cv)), attrs))); } STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) 270223 { 270223 I32 type; 270223 if (!o || PL_error_count) ###### return o; 270223 type = o->op_type; 270223 if (type == OP_LIST) { 27829 OP *kid; 136613 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 108784 my_kid(kid, attrs, imopsp); 242394 } else if (type == OP_UNDEF) { ###### return o; 242394 } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ 22158 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ ###### yyerror(Perl_form(aTHX_ "Can't declare %s in %s", OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); 22158 } else if (attrs) { ###### GV *gv = cGVOPx_gv(cUNOPo->op_first); ###### PL_in_my = FALSE; ###### PL_in_my_stash = Nullhv; ###### apply_attrs(GvSTASH(gv), (type == OP_RV2SV ? GvSV(gv) : type == OP_RV2AV ? (SV*)GvAV(gv) : type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv), attrs, FALSE); } 22158 o->op_private |= OPpOUR_INTRO; 22158 return o; } 220236 else if (type != OP_PADSV && type != OP_PADAV && type != OP_PADHV && type != OP_PUSHMARK) { ###### yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); ###### return o; } 220236 else if (attrs && type != OP_PUSHMARK) { ###### HV *stash; ###### PL_in_my = FALSE; ###### PL_in_my_stash = Nullhv; /* check for C when deciding package */ ###### stash = PAD_COMPNAME_TYPE(o->op_targ); ###### if (!stash) ###### stash = PL_curstash; ###### apply_attrs_my(stash, o, attrs, imopsp); } 248065 o->op_flags |= OPf_MOD; 248065 o->op_private |= OPpLVAL_INTRO; 248065 return o; } OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs) 161439 { 161439 OP *rops = Nullop; 161439 int maybe_scalar = 0; /* [perl #17376]: this appears to be premature, and results in code such as C< our(%x); > executing in list mode rather than void mode */ #if 0 if (o->op_flags & OPf_PARENS) list(o); else maybe_scalar = 1; #else 161439 maybe_scalar = 1; #endif 161439 if (attrs) ###### SAVEFREEOP(attrs); 161439 o = my_kid(o, attrs, &rops); 161439 if (rops) { ###### if (maybe_scalar && o->op_type == OP_PADSV) { ###### o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o)); ###### o->op_private |= OPpLVAL_INTRO; } else ###### o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); } 161439 PL_in_my = FALSE; 161439 PL_in_my_stash = Nullhv; 161439 return o; } OP * Perl_my(pTHX_ OP *o) 161195 { 161195 return my_attrs(o, Nullop); } OP * Perl_sawparens(pTHX_ OP *o) 144576 { 144576 if (o) 144576 o->op_flags |= OPf_PARENS; 144576 return o; } OP * Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) 54734 { 54734 OP *o; 54734 bool ismatchop = 0; 54734 if (ckWARN(WARN_MISC) && (left->op_type == OP_RV2AV || left->op_type == OP_RV2HV || left->op_type == OP_PADAV || left->op_type == OP_PADHV)) { ###### const char *desc = PL_op_desc[(right->op_type == OP_SUBST || right->op_type == OP_TRANS) ###### ? right->op_type : OP_MATCH]; ###### const char *sample = ((left->op_type == OP_RV2AV || left->op_type == OP_PADAV) ###### ? "@array" : "%hash"); ###### Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %s will act on scalar(%s)", desc, sample, sample); } 54734 if (right->op_type == OP_CONST && cSVOPx(right)->op_private & OPpCONST_BARE && cSVOPx(right)->op_private & OPpCONST_STRICT) { ###### no_bareword_allowed(right); } 54734 ismatchop = right->op_type == OP_MATCH || right->op_type == OP_SUBST || right->op_type == OP_TRANS; 54734 if (ismatchop && right->op_private & OPpTARGET_MY) { ###### right->op_targ = 0; ###### right->op_private &= ~OPpTARGET_MY; } 54734 if (!(right->op_flags & OPf_STACKED) && ismatchop) { 54521 right->op_flags |= OPf_STACKED; 54521 if (right->op_type != OP_MATCH && ! (right->op_type == OP_TRANS && right->op_private & OPpTRANS_IDENTICAL)) 21947 left = mod(left, right->op_type); 54521 if (right->op_type == OP_TRANS) 1294 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); else 53227 o = prepend_elem(right->op_type, scalar(left), right); 54521 if (type == OP_NOT) 3580 return newUNOP(OP_NOT, 0, scalar(o)); 50941 return o; } else 213 return bind_match(type, left, pmruntime(newPMOP(OP_MATCH, 0), right, 0)); } OP * Perl_invert(pTHX_ OP *o) 11678 { 11678 if (!o) ###### return o; /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */ 11678 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); } OP * Perl_scope(pTHX_ OP *o) 163890 { dVAR; 163890 if (o) { 163890 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { 110017 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); 110017 o->op_type = OP_LEAVE; 110017 o->op_ppaddr = PL_ppaddr[OP_LEAVE]; } 53873 else if (o->op_type == OP_LINESEQ) { 53355 OP *kid; 53355 o->op_type = OP_SCOPE; 53355 o->op_ppaddr = PL_ppaddr[OP_SCOPE]; 53355 kid = ((LISTOP*)o)->op_first; 53355 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) 53355 op_null(kid); } else 518 o = newLISTOP(OP_SCOPE, 0, o, Nullop); } 163890 return o; } /* XXX kept for BINCOMPAT only */ void Perl_save_hints(pTHX) ###### { ###### Perl_croak(aTHX_ "internal error: obsolete function save_hints() called"); } int Perl_block_start(pTHX_ int full) 375974 { 375974 const int retval = PL_savestack_ix; 375974 pad_block_start(full); 375974 SAVEHINTS(); 375974 PL_hints &= ~HINT_BLOCK_SCOPE; 375974 SAVESPTR(PL_compiling.cop_warnings); 375974 if (! specialWARN(PL_compiling.cop_warnings)) { ###### PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; ###### SAVEFREESV(PL_compiling.cop_warnings) ; } 375974 SAVESPTR(PL_compiling.cop_io); 375974 if (! specialCopIO(PL_compiling.cop_io)) { ###### PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ; ###### SAVEFREESV(PL_compiling.cop_io) ; } 375974 return retval; } OP* Perl_block_end(pTHX_ I32 floor, OP *seq) 375974 { 375974 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; 375974 OP* retval = scalarseq(seq); 375974 LEAVE_SCOPE(floor); 375974 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 375974 if (needblockscope) 280509 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ 375974 pad_leavemy(); 375974 return retval; } STATIC OP * S_newDEFSVOP(pTHX) 3170 { 3170 const I32 offset = pad_findmy("$_"); 3170 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { 3170 return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); } else { ###### OP *o = newOP(OP_PADSV, 0); ###### o->op_targ = offset; ###### return o; } } void Perl_newPROG(pTHX_ OP *o) 12652 { 12652 if (PL_in_eval) { 12087 if (PL_eval_root) ###### return; 12087 PL_eval_root = newUNOP(OP_LEAVEEVAL, ((PL_in_eval & EVAL_KEEPERR) ? OPf_SPECIAL : 0), o); 12087 PL_eval_start = linklist(PL_eval_root); 12087 PL_eval_root->op_private |= OPpREFCOUNTED; 12087 OpREFCNT_set(PL_eval_root, 1); 12087 PL_eval_root->op_next = 0; 12087 CALL_PEEP(PL_eval_start); } else { 565 if (o->op_type == OP_STUB) { ###### PL_comppad_name = 0; ###### PL_compcv = 0; ###### FreeOp(o); ###### return; } 565 PL_main_root = scope(sawparens(scalarvoid(o))); 565 PL_curcop = &PL_compiling; 565 PL_main_start = LINKLIST(PL_main_root); 565 PL_main_root->op_private |= OPpREFCOUNTED; 565 OpREFCNT_set(PL_main_root, 1); 565 PL_main_root->op_next = 0; 565 CALL_PEEP(PL_main_start); 565 PL_compcv = 0; /* Register with debugger */ 565 if (PERLDB_INTER) { ###### CV *cv = get_cv("DB::postponed", FALSE); ###### if (cv) { ###### dSP; ###### PUSHMARK(SP); ###### XPUSHs((SV*)CopFILEGV(&PL_compiling)); ###### PUTBACK; ###### call_sv((SV*)cv, G_DISCARD); } } } } OP * Perl_localize(pTHX_ OP *o, I32 lex) 165209 { 165209 if (o->op_flags & OPf_PARENS) /* [perl #17376]: this appears to be premature, and results in code such as C< our(%x); > executing in list mode rather than void mode */ #if 0 list(o); #else ; #endif else { 119493 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') { 447 char *s = PL_bufptr; 447 bool sigil = FALSE; /* some heuristics to detect a potential error */ 894 while (*s && (strchr(", \t\n", *s))) 447 s++; 864 while (1) { 864 if (*s && strchr("@$%*", *s) && *++s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) { 417 s++; 417 sigil = TRUE; 1616 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) 1199 s++; 469 while (*s && (strchr(", \t\n", *s))) 52 s++; } else 447 break; } 447 if (sigil && (*s == ';' || *s == '=')) { ###### Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), "Parentheses missing around \"%s\" list", lex ? (PL_in_my == KEY_our ? "our" : "my") : "local"); } } } 165209 if (lex) 151133 o = my(o); else 14076 o = mod(o, OP_NULL); /* a bit kludgey */ 165209 PL_in_my = FALSE; 165209 PL_in_my_stash = Nullhv; 165209 return o; } OP * Perl_jmaybe(pTHX_ OP *o) 108383 { 108383 if (o->op_type == OP_LIST) { 110 OP *o2; 110 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); } 108383 return o; } OP * Perl_fold_constants(pTHX_ register OP *o) 2655019 { dVAR; 2655019 register OP *curop; 2655019 I32 type = o->op_type; 2655019 SV *sv; 2655019 if (PL_opargs[type] & OA_RETSCALAR) 1426746 scalar(o); 2655019 if (PL_opargs[type] & OA_TARGET && !o->op_targ) 945173 o->op_targ = pad_alloc(type, SVs_PADTMP); /* integerize op, unless it happens to be C<-foo>. * XXX should pp_i_negate() do magic string negation instead? */ 2655019 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER) && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST && (cUNOPo->op_first->op_private & OPpCONST_BARE))) { ###### o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)]; } 2655019 if (!(PL_opargs[type] & OA_FOLDCONST)) 2126556 goto nope; 528463 switch (type) { case OP_NEGATE: /* XXX might want a ck_negate() for this */ 5975 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; 5975 break; case OP_SPRINTF: case OP_UCFIRST: case OP_LCFIRST: case OP_UC: case OP_LC: case OP_SLT: case OP_SGT: case OP_SLE: case OP_SGE: case OP_SCMP: /* XXX what about the numeric ops? */ 6328 if (PL_hints & HINT_LOCALE) ###### goto nope; } 528463 if (PL_error_count) ###### goto nope; /* Don't try to run w/ errors */ 1009098 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 940266 if ((curop->op_type != OP_CONST || (curop->op_private & OPpCONST_BARE)) && curop->op_type != OP_LIST && curop->op_type != OP_SCALAR && curop->op_type != OP_NULL && curop->op_type != OP_PUSHMARK) { 459631 goto nope; } } 68832 curop = LINKLIST(o); 68832 o->op_next = 0; 68832 PL_op = curop; 68832 CALLRUNOPS(aTHX); 68832 sv = *(PL_stack_sp--); 68832 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ 68827 pad_swipe(o->op_targ, FALSE); 5 else if (SvTEMP(sv)) { /* grab mortal temp? */ 3 (void)SvREFCNT_inc(sv); 3 SvTEMP_off(sv); } 68832 op_free(o); 68832 if (type == OP_RV2GV) ###### return newGVOP(OP_GV, 0, (GV*)sv); 68832 return newSVOP(OP_CONST, 0, sv); nope: 2586187 return o; } OP * Perl_gen_constant_list(pTHX_ register OP *o) 178 { dVAR; 178 register OP *curop; 178 const I32 oldtmps_floor = PL_tmps_floor; 178 list(o); 178 if (PL_error_count) ###### return o; /* Don't attempt to run with errors */ 178 PL_op = curop = LINKLIST(o); 178 o->op_next = 0; 178 CALL_PEEP(curop); 178 pp_pushmark(); 178 CALLRUNOPS(aTHX); 178 PL_op = curop; 178 pp_anonlist(); 178 PL_tmps_floor = oldtmps_floor; 178 o->op_type = OP_RV2AV; 178 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 178 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ 178 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ 178 o->op_opt = 0; /* needs to be revisited in peep() */ 178 curop = ((UNOP*)o)->op_first; 178 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--)); 178 op_free(curop); 178 linklist(o); 178 return list(o); } OP * Perl_convert(pTHX_ I32 type, I32 flags, OP *o) 385869 { dVAR; 385869 if (!o || o->op_type != OP_LIST) 236677 o = newLISTOP(OP_LIST, 0, o, Nullop); else 149192 o->op_flags &= ~OPf_WANT; 385869 if (!(PL_opargs[type] & OA_MARK)) 186095 op_null(cLISTOPo->op_first); 385869 o->op_type = (OPCODE)type; 385869 o->op_ppaddr = PL_ppaddr[type]; 385869 o->op_flags |= flags; 385869 o = CHECKOP(type, o); 385869 if (o->op_type != (unsigned)type) 10850 return o; 375019 return fold_constants(o); } /* List constructors */ OP * Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) 788964 { 788964 if (!first) 42964 return last; 746000 if (!last) 14368 return first; 731632 if (first->op_type != (unsigned)type || (type == OP_LIST && (first->op_flags & OPf_PARENS))) { 290619 return newLISTOP(type, 0, first, last); } 441013 if (first->op_flags & OPf_KIDS) 441013 ((LISTOP*)first)->op_last->op_sibling = last; else { ###### first->op_flags |= OPf_KIDS; ###### ((LISTOP*)first)->op_first = last; } 441013 ((LISTOP*)first)->op_last = last; 441013 return first; } OP * Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) 1008265 { 1008265 if (!first) 270409 return (OP*)last; 737856 if (!last) 221656 return (OP*)first; 516200 if (first->op_type != (unsigned)type) 4442 return prepend_elem(type, (OP*)first, (OP*)last); 511758 if (last->op_type != (unsigned)type) 22236 return append_elem(type, (OP*)first, (OP*)last); 489522 first->op_last->op_sibling = last->op_first; 489522 first->op_last = last->op_last; 489522 first->op_flags |= (last->op_flags & OPf_KIDS); 489522 FreeOp(last); 489522 return (OP*)first; } OP * Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) 1088130 { 1088130 if (!first) ###### return last; 1088130 if (!last) 39382 return first; 1048748 if (last->op_type == (unsigned)type) { 211052 if (type == OP_LIST) { /* already a PUSHMARK there */ 15104 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; 15104 ((LISTOP*)last)->op_first->op_sibling = first; 15104 if (!(first->op_flags & OPf_PARENS)) 15103 last->op_flags &= ~OPf_PARENS; } else { 195948 if (!(last->op_flags & OPf_KIDS)) { 57849 ((LISTOP*)last)->op_last = first; 57849 last->op_flags |= OPf_KIDS; } 195948 first->op_sibling = ((LISTOP*)last)->op_first; 195948 ((LISTOP*)last)->op_first = first; } 211052 last->op_flags |= OPf_KIDS; 211052 return last; } 837696 return newLISTOP(type, 0, first, last); } /* Constructors */ OP * Perl_newNULLLIST(pTHX) 6635 { 6635 return newOP(OP_STUB, 0); } OP * Perl_force_list(pTHX_ OP *o) 353996 { 353996 if (!o || o->op_type != OP_LIST) 229142 o = newLISTOP(OP_LIST, 0, o, Nullop); 353996 op_null(o); 353996 return o; } OP * Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 1598775 { dVAR; 1598775 LISTOP *listop; 1598775 NewOp(1101, listop, 1, LISTOP); 1598775 listop->op_type = (OPCODE)type; 1598775 listop->op_ppaddr = PL_ppaddr[type]; 1598775 if (first || last) 1590537 flags |= OPf_KIDS; 1598775 listop->op_flags = (U8)flags; 1598775 if (!last && first) 458099 last = first; 1140676 else if (!first && last) ###### first = last; 1140676 else if (first) 1132438 first->op_sibling = last; 1598775 listop->op_first = first; 1598775 listop->op_last = last; 1598775 if (type == OP_LIST) { 786571 OP* pushop; 786571 pushop = newOP(OP_PUSHMARK, 0); 786571 pushop->op_sibling = first; 786571 listop->op_first = pushop; 786571 listop->op_flags |= OPf_KIDS; 786571 if (!last) 8238 listop->op_last = pushop; } 1598775 return CHECKOP(type, listop); } OP * Perl_newOP(pTHX_ I32 type, I32 flags) 1943232 { dVAR; 1943232 OP *o; 1943232 NewOp(1101, o, 1, OP); 1943232 o->op_type = (OPCODE)type; 1943232 o->op_ppaddr = PL_ppaddr[type]; 1943232 o->op_flags = (U8)flags; 1943232 o->op_next = o; 1943232 o->op_private = (U8)(0 | (flags >> 8)); 1943232 if (PL_opargs[type] & OA_RETSCALAR) 866736 scalar(o); 1943232 if (PL_opargs[type] & OA_TARGET) 3237 o->op_targ = pad_alloc(type, SVs_PADTMP); 1943232 return CHECKOP(type, o); } OP * Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) 1535278 { dVAR; 1535278 UNOP *unop; 1535278 if (!first) ###### first = newOP(OP_STUB, 0); 1535278 if (PL_opargs[type] & OA_MARK) 158462 first = force_list(first); 1535278 NewOp(1101, unop, 1, UNOP); 1535278 unop->op_type = (OPCODE)type; 1535278 unop->op_ppaddr = PL_ppaddr[type]; 1535278 unop->op_first = first; 1535278 unop->op_flags = flags | OPf_KIDS; 1535278 unop->op_private = (U8)(1 | (flags >> 8)); 1535278 unop = (UNOP*) CHECKOP(type, unop); 1535278 if (unop->op_next) 34237 return (OP*)unop; 1501041 return fold_constants((OP *) unop); } OP * Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 787574 { dVAR; 787574 BINOP *binop; 787574 NewOp(1101, binop, 1, BINOP); 787574 if (!first) ###### first = newOP(OP_NULL, 0); 787574 binop->op_type = (OPCODE)type; 787574 binop->op_ppaddr = PL_ppaddr[type]; 787574 binop->op_first = first; 787574 binop->op_flags = flags | OPf_KIDS; 787574 if (!last) { ###### last = first; ###### binop->op_private = (U8)(1 | (flags >> 8)); } else { 787574 binop->op_private = (U8)(2 | (flags >> 8)); 787574 first->op_sibling = last; } 787574 binop = (BINOP*)CHECKOP(type, binop); 787574 if (binop->op_next || binop->op_type != (OPCODE)type) 8615 return (OP*)binop; 778959 binop->op_last = binop->op_first->op_sibling; 778959 return fold_constants((OP *)binop); } static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__; static int uvcompare(const void *a, const void *b) ###### { ###### if (*((const UV *)a) < (*(const UV *)b)) ###### return -1; ###### if (*((const UV *)a) > (*(const UV *)b)) ###### return 1; ###### if (*((const UV *)a+1) < (*(const UV *)b+1)) ###### return -1; ###### if (*((const UV *)a+1) > (*(const UV *)b+1)) ###### return 1; ###### return 0; } OP * Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 1317 { 1317 SV *tstr = ((SVOP*)expr)->op_sv; 1317 SV *rstr = ((SVOP*)repl)->op_sv; 1317 STRLEN tlen; 1317 STRLEN rlen; 1317 const U8 *t = (U8*)SvPV_const(tstr, tlen); 1317 const U8 *r = (U8*)SvPV_const(rstr, rlen); 1317 register I32 i; 1317 register I32 j; 1317 I32 del; 1317 I32 complement; 1317 I32 squash; 1317 I32 grows = 0; 1317 register short *tbl; 1317 PL_hints |= HINT_BLOCK_SCOPE; 1317 complement = o->op_private & OPpTRANS_COMPLEMENT; 1317 del = o->op_private & OPpTRANS_DELETE; 1317 squash = o->op_private & OPpTRANS_SQUASH; 1317 if (SvUTF8(tstr)) ###### o->op_private |= OPpTRANS_FROM_UTF; 1317 if (SvUTF8(rstr)) ###### o->op_private |= OPpTRANS_TO_UTF; 1317 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { ###### SV* listsv = newSVpvn("# comment\n",10); ###### SV* transv = 0; ###### const U8* tend = t + tlen; ###### const U8* rend = r + rlen; ###### STRLEN ulen; ###### UV tfirst = 1; ###### UV tlast = 0; ###### IV tdiff; ###### UV rfirst = 1; ###### UV rlast = 0; ###### IV rdiff; ###### IV diff; ###### I32 none = 0; ###### U32 max = 0; ###### I32 bits; ###### I32 havefinal = 0; ###### U32 final = 0; ###### I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; ###### I32 to_utf = o->op_private & OPpTRANS_TO_UTF; ###### U8* tsave = NULL; ###### U8* rsave = NULL; ###### if (!from_utf) { ###### STRLEN len = tlen; ###### t = tsave = bytes_to_utf8(t, &len); ###### tend = t + len; } ###### if (!to_utf && rlen) { ###### STRLEN len = rlen; ###### r = rsave = bytes_to_utf8(r, &len); ###### rend = r + len; } /* There are several snags with this code on EBCDIC: 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes). 2. scan_const() in toke.c has encoded chars in native encoding which makes ranges at least in EBCDIC 0..255 range the bottom odd. */ ###### if (complement) { ###### U8 tmpbuf[UTF8_MAXBYTES+1]; ###### UV *cp; ###### UV nextmin = 0; ###### New(1109, cp, 2*tlen, UV); ###### i = 0; ###### transv = newSVpvn("",0); ###### while (t < tend) { ###### cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0); ###### t += ulen; ###### if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { ###### t++; ###### cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0); ###### t += ulen; } else { ###### cp[2*i+1] = cp[2*i]; } ###### i++; } ###### qsort(cp, i, 2*sizeof(UV), uvcompare); ###### for (j = 0; j < i; j++) { ###### UV val = cp[2*j]; ###### diff = val - nextmin; ###### if (diff > 0) { ###### t = uvuni_to_utf8(tmpbuf,nextmin); ###### sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); ###### if (diff > 1) { ###### U8 range_mark = UTF_TO_NATIVE(0xff); ###### t = uvuni_to_utf8(tmpbuf, val - 1); ###### sv_catpvn(transv, (char *)&range_mark, 1); ###### sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); } } ###### val = cp[2*j+1]; ###### if (val >= nextmin) ###### nextmin = val + 1; } ###### t = uvuni_to_utf8(tmpbuf,nextmin); ###### sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); { ###### U8 range_mark = UTF_TO_NATIVE(0xff); ###### sv_catpvn(transv, (char *)&range_mark, 1); } ###### t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff, UNICODE_ALLOW_SUPER); ###### sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); ###### t = (const U8*)SvPVX_const(transv); ###### tlen = SvCUR(transv); ###### tend = t + tlen; ###### Safefree(cp); } ###### else if (!rlen && !del) { ###### r = t; rlen = tlen; rend = tend; } ###### if (!squash) { ###### if ((!rlen && !del) || t == r || (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) { ###### o->op_private |= OPpTRANS_IDENTICAL; } } ###### while (t < tend || tfirst <= tlast) { /* see if we need more "t" chars */ ###### if (tfirst > tlast) { ###### tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); ###### t += ulen; ###### if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ ###### t++; ###### tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); ###### t += ulen; } else ###### tlast = tfirst; } /* now see if we need more "r" chars */ ###### if (rfirst > rlast) { ###### if (r < rend) { ###### rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); ###### r += ulen; ###### if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ ###### r++; ###### rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); ###### r += ulen; } else ###### rlast = rfirst; } else { ###### if (!havefinal++) ###### final = rlast; ###### rfirst = rlast = 0xffffffff; } } /* now see which range will peter our first, if either. */ ###### tdiff = tlast - tfirst; ###### rdiff = rlast - rfirst; ###### if (tdiff <= rdiff) ###### diff = tdiff; else ###### diff = rdiff; ###### if (rfirst == 0xffffffff) { ###### diff = tdiff; /* oops, pretend rdiff is infinite */ ###### if (diff > 0) ###### Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n", (long)tfirst, (long)tlast); else ###### Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst); } else { ###### if (diff > 0) ###### Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n", (long)tfirst, (long)(tfirst + diff), (long)rfirst); else ###### Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n", (long)tfirst, (long)rfirst); ###### if (rfirst + diff > max) ###### max = rfirst + diff; ###### if (!grows) ###### grows = (tfirst < rfirst && UNISKIP(tfirst) < UNISKIP(rfirst + diff)); ###### rfirst += diff + 1; } ###### tfirst += diff + 1; } ###### none = ++max; ###### if (del) ###### del = ++max; ###### if (max > 0xffff) ###### bits = 32; ###### else if (max > 0xff) ###### bits = 16; else ###### bits = 8; ###### Safefree(cPVOPo->op_pv); ###### cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none); ###### SvREFCNT_dec(listsv); ###### if (transv) ###### SvREFCNT_dec(transv); ###### if (!del && havefinal && rlen) ###### (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, newSVuv((UV)final), 0); ###### if (grows) ###### o->op_private |= OPpTRANS_GROWS; ###### if (tsave) ###### Safefree(tsave); ###### if (rsave) ###### Safefree(rsave); ###### op_free(expr); ###### op_free(repl); ###### return o; } 1317 tbl = (short*)cPVOPo->op_pv; 1317 if (complement) { 1 Zero(tbl, 256, short); 64 for (i = 0; i < (I32)tlen; i++) 63 tbl[t[i]] = -1; 257 for (i = 0, j = 0; i < 256; i++) { 256 if (!tbl[i]) { 193 if (j >= (I32)rlen) { 193 if (del) 193 tbl[i] = -2; ###### else if (rlen) ###### tbl[i] = r[j-1]; else ###### tbl[i] = (short)i; } else { ###### if (i < 128 && r[j] >= 128) ###### grows = 1; ###### tbl[i] = r[j++]; } } } 1 if (!del) { ###### if (!rlen) { ###### j = rlen; ###### if (!squash) ###### o->op_private |= OPpTRANS_IDENTICAL; } ###### else if (j >= (I32)rlen) ###### j = rlen - 1; else ###### cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short); ###### tbl[0x100] = rlen - j; ###### for (i=0; i < (I32)rlen - j; i++) ###### tbl[0x101+i] = r[j+i]; } } else { 1316 if (!rlen && !del) { 519 r = t; rlen = tlen; 519 if (!squash) 519 o->op_private |= OPpTRANS_IDENTICAL; } 797 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) { 3 o->op_private |= OPpTRANS_IDENTICAL; } 338212 for (i = 0; i < 256; i++) 336896 tbl[i] = -1; 37215 for (i = 0, j = 0; i < (I32)tlen; i++,j++) { 35899 if (j >= (I32)rlen) { 4295 if (del) { 11 if (tbl[t[i]] == -1) 9 tbl[t[i]] = -2; 9 continue; } 4284 --j; } 35888 if (tbl[t[i]] == -1) { 35888 if (t[i] < 128 && r[j] >= 128) ###### grows = 1; 35888 tbl[t[i]] = r[j]; } } } 1317 if (grows) ###### o->op_private |= OPpTRANS_GROWS; 1317 op_free(expr); 1317 op_free(repl); 1317 return o; } OP * Perl_newPMOP(pTHX_ I32 type, I32 flags) 70148 { dVAR; 70148 PMOP *pmop; 70148 NewOp(1101, pmop, 1, PMOP); 70148 pmop->op_type = (OPCODE)type; 70148 pmop->op_ppaddr = PL_ppaddr[type]; 70148 pmop->op_flags = (U8)flags; 70148 pmop->op_private = (U8)(0 | (flags >> 8)); 70148 if (PL_hints & HINT_RE_TAINT) 14618 pmop->op_pmpermflags |= PMf_RETAINT; 70148 if (PL_hints & HINT_LOCALE) ###### pmop->op_pmpermflags |= PMf_LOCALE; 70148 pmop->op_pmflags = pmop->op_pmpermflags; #ifdef USE_ITHREADS { SV* repointer; if(av_len((AV*) PL_regex_pad[0]) > -1) { repointer = av_pop((AV*)PL_regex_pad[0]); pmop->op_pmoffset = SvIV(repointer); SvREPADTMP_off(repointer); sv_setiv(repointer,0); } else { repointer = newSViv(0); av_push(PL_regex_padav,SvREFCNT_inc(repointer)); pmop->op_pmoffset = av_len(PL_regex_padav); PL_regex_pad = AvARRAY(PL_regex_padav); } } #endif /* link into pm list */ 70148 if (type != OP_TRANS && PL_curstash) { 70148 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab); 70148 if (!mg) { 6167 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0); } 70148 pmop->op_pmnext = (PMOP*)mg->mg_obj; 70148 mg->mg_obj = (SV*)pmop; 70148 PmopSTASH_set(pmop,PL_curstash); } 70148 return CHECKOP(type, pmop); } /* Given some sort of match op o, and an expression expr containing a * pattern, either compile expr into a regex and attach it to o (if it's * constant), or convert expr into a runtime regcomp op sequence (if it's * not) * * isreg indicates that the pattern is part of a regex construct, eg * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or * split "pattern", which aren't. In the former case, expr will be a list * if the pattern contains more than one term (eg /a$b/) or if it contains * a replacement, ie s/// or tr///. */ OP * Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) 71465 { dVAR; 71465 PMOP *pm; 71465 LOGOP *rcop; 71465 I32 repl_has_vars = 0; 71465 OP* repl = Nullop; 71465 bool reglist; 71465 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) { /* last element in list is the replacement; pop it */ 25385 OP* kid; 25385 repl = cLISTOPx(expr)->op_last; 25385 kid = cLISTOPx(expr)->op_first; 53096 while (kid->op_sibling != repl) 27711 kid = kid->op_sibling; 25385 kid->op_sibling = Nullop; 25385 cLISTOPx(expr)->op_last = kid; } 71465 if (isreg && expr->op_type == OP_LIST && cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last) { /* convert single element list to element */ 24125 OP* oe = expr; 24125 expr = cLISTOPx(oe)->op_first->op_sibling; 24125 cLISTOPx(oe)->op_first->op_sibling = Nullop; 24125 cLISTOPx(oe)->op_last = Nullop; 24125 op_free(oe); } 71465 if (o->op_type == OP_TRANS) { 1317 return pmtrans(o, expr, repl); } 70148 reglist = isreg && expr->op_type == OP_LIST; 70148 if (reglist) 4184 op_null(expr); 70148 PL_hints |= HINT_BLOCK_SCOPE; 70148 pm = (PMOP*)o; 70148 if (expr->op_type == OP_CONST) { 63931 STRLEN plen; 63931 SV *pat = ((SVOP*)expr)->op_sv; 63931 const char *p = SvPV_const(pat, plen); 63931 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { 562 U32 was_readonly = SvREADONLY(pat); 562 if (was_readonly) { 562 if (SvFAKE(pat)) { ###### sv_force_normal_flags(pat, 0); ###### assert(!SvREADONLY(pat)); ###### was_readonly = 0; } else { 562 SvREADONLY_off(pat); } } 562 sv_setpvn(pat, "\\s+", 3); 562 SvFLAGS(pat) |= was_readonly; 562 p = SvPV_const(pat, plen); 562 pm->op_pmflags |= PMf_SKIPWHITE; } 63931 if (DO_UTF8(pat)) ###### pm->op_pmdynflags |= PMdf_UTF8; /* FIXME - can we make this function take const char * args? */ 63931 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm)); 63931 if (strEQ("\\s+", PM_GETRE(pm)->precomp)) 1127 pm->op_pmflags |= PMf_WHITE; 63931 op_free(expr); } else { 6217 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) 6170 expr = newUNOP((!(PL_hints & HINT_RE_EVAL) ? OP_REGCRESET : OP_REGCMAYBE),0,expr); 6217 NewOp(1101, rcop, 1, LOGOP); 6217 rcop->op_type = OP_REGCOMP; 6217 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; 6217 rcop->op_first = scalar(expr); 6217 rcop->op_flags |= OPf_KIDS | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) | (reglist ? OPf_STACKED : 0); 6217 rcop->op_private = 1; 6217 rcop->op_other = o; 6217 if (reglist) 4184 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP); /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ 6217 PL_cv_has_eval = 1; /* establish postfix order */ 6217 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) { 6170 LINKLIST(expr); 6170 rcop->op_next = expr; 6170 ((UNOP*)expr)->op_first->op_next = (OP*)rcop; } else { 47 rcop->op_next = LINKLIST(expr); 47 expr->op_next = (OP*)rcop; } 6217 prepend_elem(o->op_type, scalar((OP*)rcop), o); } 70148 if (repl) { 24068 OP *curop; 24068 if (pm->op_pmflags & PMf_EVAL) { 785 curop = 0; 785 if (CopLINE(PL_curcop) < (line_t)PL_multi_end) ###### CopLINE_set(PL_curcop, (line_t)PL_multi_end); } 23283 else if (repl->op_type == OP_CONST) 17601 curop = repl; else { 5682 OP *lastop = 0; 8357 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { 7801 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 6159 if (curop->op_type == OP_GV) { 5368 GV *gv = cGVOPx_gv(curop); 5368 repl_has_vars = 1; 5368 if (strchr("&`'123456789+-\016\022", *GvENAME(gv))) 4896 break; } 791 else if (curop->op_type == OP_RV2CV) ###### break; 791 else if (curop->op_type == OP_RV2SV || curop->op_type == OP_RV2AV || curop->op_type == OP_RV2HV || curop->op_type == OP_RV2GV) { 559 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/ 230 break; } 232 else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || curop->op_type == OP_PADANY) { 232 repl_has_vars = 1; } ###### else if (curop->op_type == OP_PUSHRE) ; /* Okay here, dangerous in newASSIGNOP */ else 2675 break; } 2675 lastop = curop; } } 24068 if (curop == repl && !(repl_has_vars && (!PM_GETRE(pm) || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) { 18110 pm->op_pmflags |= PMf_CONST; /* const for long enough */ 18110 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ 18110 prepend_elem(o->op_type, scalar(repl), o); } else { 5958 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */ 47 pm->op_pmflags |= PMf_MAYBE_CONST; 47 pm->op_pmpermflags |= PMf_MAYBE_CONST; } 5958 NewOp(1101, rcop, 1, LOGOP); 5958 rcop->op_type = OP_SUBSTCONT; 5958 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT]; 5958 rcop->op_first = scalar(repl); 5958 rcop->op_flags |= OPf_KIDS; 5958 rcop->op_private = 1; 5958 rcop->op_other = o; /* establish postfix order */ 5958 rcop->op_next = LINKLIST(repl); 5958 repl->op_next = (OP*)rcop; 5958 pm->op_pmreplroot = scalar((OP*)rcop); 5958 pm->op_pmreplstart = LINKLIST(rcop); 5958 rcop->op_next = 0; } } 70148 return (OP*)pm; } OP * Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) 1810678 { dVAR; 1810678 SVOP *svop; 1810678 NewOp(1101, svop, 1, SVOP); 1810678 svop->op_type = (OPCODE)type; 1810678 svop->op_ppaddr = PL_ppaddr[type]; 1810678 svop->op_sv = sv; 1810678 svop->op_next = (OP*)svop; 1810678 svop->op_flags = (U8)flags; 1810678 if (PL_opargs[type] & OA_RETSCALAR) 1757492 scalar((OP*)svop); 1810678 if (PL_opargs[type] & OA_TARGET) 1055 svop->op_targ = pad_alloc(type, SVs_PADTMP); 1810678 return CHECKOP(type, svop); } OP * Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) ###### { dVAR; ###### PADOP *padop; ###### NewOp(1101, padop, 1, PADOP); ###### padop->op_type = (OPCODE)type; ###### padop->op_ppaddr = PL_ppaddr[type]; ###### padop->op_padix = pad_alloc(type, SVs_PADTMP); ###### SvREFCNT_dec(PAD_SVl(padop->op_padix)); ###### PAD_SETSV(padop->op_padix, sv); ###### if (sv) ###### SvPADTMP_on(sv); ###### padop->op_next = (OP*)padop; ###### padop->op_flags = (U8)flags; ###### if (PL_opargs[type] & OA_RETSCALAR) ###### scalar((OP*)padop); ###### if (PL_opargs[type] & OA_TARGET) ###### padop->op_targ = pad_alloc(type, SVs_PADTMP); ###### return CHECKOP(type, padop); } OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) 52035 { dVAR; #ifdef USE_ITHREADS if (gv) GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc(gv)); #else 52035 return newSVOP(type, flags, SvREFCNT_inc(gv)); #endif } OP * Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) 8706 { dVAR; 8706 PVOP *pvop; 8706 NewOp(1101, pvop, 1, PVOP); 8706 pvop->op_type = (OPCODE)type; 8706 pvop->op_ppaddr = PL_ppaddr[type]; 8706 pvop->op_pv = pv; 8706 pvop->op_next = (OP*)pvop; 8706 pvop->op_flags = (U8)flags; 8706 if (PL_opargs[type] & OA_RETSCALAR) 8706 scalar((OP*)pvop); 8706 if (PL_opargs[type] & OA_TARGET) ###### pvop->op_targ = pad_alloc(type, SVs_PADTMP); 8706 return CHECKOP(type, pvop); } void Perl_package(pTHX_ OP *o) 10455 { 10455 const char *name; 10455 STRLEN len; 10455 save_hptr(&PL_curstash); 10455 save_item(PL_curstname); 10455 name = SvPV_const(cSVOPo->op_sv, len); 10455 PL_curstash = gv_stashpvn(name, len, TRUE); 10455 sv_setpvn(PL_curstname, name, len); 10455 op_free(o); 10455 PL_hints |= HINT_BLOCK_SCOPE; 10455 PL_copline = NOLINE; 10455 PL_expect = XSTATE; } void Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) 22597 { 22597 OP *pack; 22597 OP *imop; 22597 OP *veop; 22597 if (idop->op_type != OP_CONST) ###### Perl_croak(aTHX_ "Module name must be constant"); 22597 veop = Nullop; 22597 if (version != Nullop) { 6 SV *vesv = ((SVOP*)version)->op_sv; 6 if (arg == Nullop && !SvNIOKp(vesv)) { ###### arg = version; } else { 6 OP *pack; 6 SV *meth; 6 if (version->op_type != OP_CONST || !SvNIOKp(vesv)) ###### Perl_croak(aTHX_ "Version number must be constant number"); /* Make copy of idop so we don't free it twice */ 6 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to VERSION */ 6 meth = newSVpvn_share("VERSION", 7, 0); 6 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(version)), newSVOP(OP_METHOD_NAMED, 0, meth))); } } /* Fake up an import/unimport */ 22597 if (arg && arg->op_type == OP_STUB) 1065 imop = arg; /* no import on explicit () */ 21532 else if (SvNIOKp(((SVOP*)idop)->op_sv)) { 2837 imop = Nullop; /* use 5.0; */ } else { 18695 SV *meth; /* Make copy of idop so we don't free it twice */ 18695 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to import/unimport */ 18695 meth = aver ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0); 18695 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, prepend_elem(OP_LIST, pack, list(arg)), newSVOP(OP_METHOD_NAMED, 0, meth))); } /* Fake up the BEGIN {}, which does its thing immediately. */ 22597 newATTRSUB(floor, newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)), Nullop, Nullop, append_elem(OP_LINESEQ, append_elem(OP_LINESEQ, newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)), newSTATEOP(0, Nullch, veop)), newSTATEOP(0, Nullch, imop) )); /* The "did you use incorrect case?" warning used to be here. * The problem is that on case-insensitive filesystems one * might get false positives for "use" (and "require"): * "use Strict" or "require CARP" will work. This causes * portability problems for the script: in case-strict * filesystems the script will stop working. * * The "incorrect case" warning checked whether "use Foo" * imported "Foo" to your namespace, but that is wrong, too: * there is no requirement nor promise in the language that * a Foo.pm should or would contain anything in package "Foo". * * There is very little Configure-wise that can be done, either: * the case-sensitivity of the build filesystem of Perl does not * help in guessing the case-sensitivity of the runtime environment. */ 22597 PL_hints |= HINT_BLOCK_SCOPE; 22597 PL_copline = NOLINE; 22597 PL_expect = XSTATE; 22597 PL_cop_seqmax++; /* Purely for B::*'s benefit */ } /* =head1 Embedding Functions =for apidoc load_module Loads the module whose name is pointed to by the string part of name. Note that the actual module name, not its filename, should be given. Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS (or 0 for no flags). ver, if specified, provides version semantics similar to C. The optional trailing SV* arguments can be used to specify arguments to the module's import() method, similar to C. =cut */ void Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) ###### { ###### va_list args; ###### va_start(args, ver); ###### vload_module(flags, name, ver, &args); va_end(args); } #ifdef PERL_IMPLICIT_CONTEXT void Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) { dTHX; va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif void Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) ###### { ###### OP *modname, *veop, *imop; ###### modname = newSVOP(OP_CONST, 0, name); ###### modname->op_private |= OPpCONST_BARE; ###### if (ver) { ###### veop = newSVOP(OP_CONST, 0, ver); } else ###### veop = Nullop; ###### if (flags & PERL_LOADMOD_NOIMPORT) { ###### imop = sawparens(newNULLLIST()); } ###### else if (flags & PERL_LOADMOD_IMPORT_OPS) { ###### imop = va_arg(*args, OP*); } else { ###### SV *sv; ###### imop = Nullop; ###### sv = va_arg(*args, SV*); ###### while (sv) { ###### imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); ###### sv = va_arg(*args, SV*); } } { ###### const line_t ocopline = PL_copline; ###### COP * const ocurcop = PL_curcop; ###### const int oexpect = PL_expect; ###### utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); ###### PL_expect = oexpect; ###### PL_copline = ocopline; ###### PL_curcop = ocurcop; } } OP * Perl_dofile(pTHX_ OP *term) 326 { 326 OP *doop; 326 GV *gv; 326 gv = gv_fetchpv("do", FALSE, SVt_PVCV); 326 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) 326 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV); 326 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { ###### doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, term, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv)))))); } else { 326 doop = newUNOP(OP_DOFILE, 0, scalar(term)); } 326 return doop; } OP * Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) 6379 { 6379 return newBINOP(OP_LSLICE, flags, list(force_list(subscript)), list(force_list(listval)) ); } STATIC I32 S_is_list_assignment(pTHX_ register const OP *o) 293742 { 293742 if (!o) ###### return TRUE; 293742 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS) 86 o = cUNOPo->op_first; 293742 if (o->op_type == OP_COND_EXPR) { 86 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); 86 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); 86 if (t && f) ###### return TRUE; 86 if (t || f) ###### yyerror("Assignment to both a list and a scalar"); 86 return FALSE; } 293656 if (o->op_type == OP_LIST && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR && o->op_private & OPpLVAL_INTRO) ###### return FALSE; 293656 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS || o->op_type == OP_RV2AV || o->op_type == OP_RV2HV || o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) 61961 return TRUE; 231695 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) 20360 return TRUE; 211335 if (o->op_type == OP_RV2SV) 39998 return FALSE; 171337 return FALSE; } OP * Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) 325519 { 325519 OP *o; 325519 if (optype) { 31949 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { 9327 return newLOGOP(optype, 0, mod(scalar(left), optype), newUNOP(OP_SASSIGN, 0, scalar(right))); } else { 22622 return newBINOP(optype, OPf_STACKED, mod(scalar(left), optype), scalar(right)); } } 293570 if (is_list_assignment(left)) { 82321 OP *curop; 82321 PL_modcount = 0; /* Grandfathering $[ assignment here. Bletch.*/ /* Only simple assignments like C<< ($[) = 1 >> are allowed */ 82321 PL_eval_start = (left->op_type == OP_CONST) ? right : 0; 82321 left = mod(left, OP_AASSIGN); 82321 if (PL_eval_start) ###### PL_eval_start = 0; 82321 else if (left->op_type == OP_CONST) { /* Result of assignment is always 1 (or we'd be dead already) */ ###### return newSVOP(OP_CONST, 0, newSViv(1)); } /* optimise C to C, and likewise for hashes */ 82321 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV) && right->op_type == OP_STUB && (left->op_private & OPpLVAL_INTRO)) { 1088 op_free(right); 1088 left->op_flags &= ~(OPf_REF|OPf_SPECIAL); 1088 return left; } 81233 curop = list(force_list(left)); 81233 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); 81233 o->op_private = (U8)(0 | (flags >> 8)); /* PL_generation sorcery: * an assignment like ($a,$b) = ($c,$d) is easier than * ($a,$b) = ($c,$a), since there is no need for temporary vars. * To detect whether there are common vars, the global var * PL_generation is incremented for each assign op we compile. * Then, while compiling the assign op, we run through all the * variables on both sides of the assignment, setting a spare slot * in each of them to PL_generation. If any of them already have * that value, we know we've got commonality. We could use a * single bit marker, but then we'd have to make 2 passes, first * to clear the flag, then to test and set it. To find somewhere * to store these values, evil chicanery is done with SvCUR(). */ 81233 if (!(left->op_private & OPpLVAL_INTRO)) { 36082 OP *lastop = o; 36082 PL_generation++; 427695 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 406741 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 85897 if (curop->op_type == OP_GV) { 22038 GV *gv = cGVOPx_gv(curop); 22038 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) 20674 break; 20674 SvCUR_set(gv, PL_generation); } 63859 else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || curop->op_type == OP_PADANY) { 32060 if (PAD_COMPNAME_GEN(curop->op_targ) == (STRLEN)PL_generation) 1158 break; 30902 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation); } 31799 else if (curop->op_type == OP_RV2CV) ###### break; 31799 else if (curop->op_type == OP_RV2SV || curop->op_type == OP_RV2AV || curop->op_type == OP_RV2HV || curop->op_type == OP_RV2GV) { 22794 if (lastop->op_type != OP_GV) /* funny deref? */ 3898 break; } 9005 else if (curop->op_type == OP_PUSHRE) { 297 if (((PMOP*)curop)->op_pmreplroot) { #ifdef USE_ITHREADS GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET, ((PMOP*)curop)->op_pmreplroot)); #else ###### GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; #endif ###### if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) ###### break; ###### SvCUR_set(gv, PL_generation); } } else 391613 break; } 391613 lastop = curop; } 36082 if (curop != o) 15128 o->op_private |= OPpASSIGN_COMMON; } 81233 if (right && right->op_type == OP_SPLIT) { 2096 OP* tmpop; 2096 if ((tmpop = ((LISTOP*)right)->op_first) && tmpop->op_type == OP_PUSHRE) { 2096 PMOP *pm = (PMOP*)tmpop; 2096 if (left->op_type == OP_RV2AV && !(left->op_private & OPpLVAL_INTRO) && !(o->op_private & OPpASSIGN_COMMON) ) { 3 tmpop = ((UNOP*)left)->op_first; 3 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) { #ifdef USE_ITHREADS pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix); cPADOPx(tmpop)->op_padix = 0; /* steal it */ #else 3 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv; 3 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */ #endif 3 pm->op_pmflags |= PMf_ONCE; 3 tmpop = cUNOPo->op_first; /* to list (nulled) */ 3 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ 3 tmpop->op_sibling = Nullop; /* don't free split */ 3 right->op_next = tmpop->op_next; /* fix starting loc */ 3 op_free(o); /* blow off assign */ 3 right->op_flags &= ~OPf_WANT; /* "I don't know and I don't care." */ 3 return right; } } else { 2093 if (PL_modcount < RETURN_UNLIMITED_NUMBER && ((LISTOP*)right)->op_last->op_type == OP_CONST) { 186 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; 186 if (SvIVX(sv) == 0) 128 sv_setiv(sv, PL_modcount+1); } } } } 81230 return o; } 211249 if (!right) ###### right = newOP(OP_UNDEF, 0); 211249 if (right->op_type == OP_READLINE) { 2736 right->op_flags |= OPf_STACKED; 2736 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right)); } else { 208513 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ 208513 o = newBINOP(OP_SASSIGN, flags, scalar(right), mod(scalar(left), OP_SASSIGN) ); 208513 if (PL_eval_start) 208513 PL_eval_start = 0; else { ###### o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase)); } } 208513 return o; } OP * Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) 830221 { dVAR; 830221 const U32 seq = intro_my(); 830221 register COP *cop; 830221 NewOp(1101, cop, 1, COP); 830221 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) { ###### cop->op_type = OP_DBSTATE; ###### cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ]; } else { 830221 cop->op_type = OP_NEXTSTATE; 830221 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; } 830221 cop->op_flags = (U8)flags; 830221 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif 830221 PL_compiling.op_private = cop->op_private; 830221 cop->op_next = (OP*)cop; 830221 if (label) { 2794 cop->cop_label = label; 2794 PL_hints |= HINT_BLOCK_SCOPE; } 830221 cop->cop_seq = seq; 830221 cop->cop_arybase = PL_curcop->cop_arybase; 830221 if (specialWARN(PL_curcop->cop_warnings)) 830039 cop->cop_warnings = PL_curcop->cop_warnings ; else 182 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ; 830221 if (specialCopIO(PL_curcop->cop_io)) 830221 cop->cop_io = PL_curcop->cop_io; else ###### cop->cop_io = newSVsv(PL_curcop->cop_io) ; 830221 if (PL_copline == NOLINE) 50271 CopLINE_set(cop, CopLINE(PL_curcop)); else { 779950 CopLINE_set(cop, PL_copline); 779950 PL_copline = NOLINE; } #ifdef USE_ITHREADS CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ #else 830221 CopFILEGV_set(cop, CopFILEGV(PL_curcop)); #endif 830221 CopSTASH_set(cop, PL_curstash); 830221 if (PERLDB_LINE && PL_curstash != PL_debstash) { ###### SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE); ###### if (svp && *svp != &PL_sv_undef ) { ###### (void)SvIOK_on(*svp); ###### SvIV_set(*svp, PTR2IV(cop)); } } 830221 return prepend_elem(OP_LINESEQ, (OP*)cop, o); } OP * Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) 246001 { dVAR; 246001 return new_logop(type, flags, &first, &other); } STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) 274317 { dVAR; 274317 LOGOP *logop; 274317 OP *o; 274317 OP *first = *firstp; 274317 OP *other = *otherp; 274317 if (type == OP_XOR) /* Not short circuit, but here by precedence. */ 8 return newBINOP(type, flags, scalar(first), scalar(other)); 274309 scalarboolean(first); /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ 274309 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) { 11452 if (type == OP_AND || type == OP_OR) { 11452 if (type == OP_AND) 11452 type = OP_OR; else ###### type = OP_AND; 11452 o = first; 11452 first = *firstp = cUNOPo->op_first; 11452 if (o->op_next) 11452 first->op_next = o->op_next; 11452 cUNOPo->op_first = Nullop; 11452 op_free(o); } } 274309 if (first->op_type == OP_CONST) { 1163 if (first->op_private & OPpCONST_STRICT) ###### no_bareword_allowed(first); 1163 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) ###### Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); 1163 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) || ###### (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) || (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) { 1162 op_free(first); 1162 *firstp = Nullop; 1162 if (other->op_type == OP_CONST) ###### other->op_private |= OPpCONST_SHORTCIRCUIT; 1162 return other; } else { /* check for C, or C */ 1 const OP *o2 = other; 1 if ( ! (o2->op_type == OP_LIST && (( o2 = cUNOPx(o2)->op_first)) && o2->op_type == OP_PUSHMARK && (( o2 = o2->op_sibling)) ) ) 1 o2 = other; 1 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV || o2->op_type == OP_PADHV) && o2->op_private & OPpLVAL_INTRO && ckWARN(WARN_DEPRECATED)) { ###### Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Deprecated use of my() in false conditional"); } 1 op_free(other); 1 *otherp = Nullop; 1 if (first->op_type == OP_CONST) 1 first->op_private |= OPpCONST_SHORTCIRCUIT; 1 return first; } } 273146 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) && type != OP_DOR) /* [#24076] Don't warn for err FOO. */ { 68415 const OP *k1 = ((UNOP*)first)->op_first; 68415 const OP *k2 = k1->op_sibling; 68415 OPCODE warnop = 0; 68415 switch (first->op_type) { case OP_NULL: 19507 if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) { ###### warnop = k2->op_type; } ###### break; case OP_SASSIGN: 364 if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH) { ###### warnop = ((k1->op_type == OP_NULL) ? (OPCODE)k1->op_targ : k1->op_type); } break; } 68415 if (warnop) { ###### const line_t oldline = CopLINE(PL_curcop); ###### CopLINE_set(PL_curcop, PL_copline); ###### Perl_warner(aTHX_ packWARN(WARN_MISC), "Value of %s%s can be \"0\"; test with defined()", PL_op_desc[warnop], ((warnop == OP_READLINE || warnop == OP_GLOB) ? " construct" : "() operator")); ###### CopLINE_set(PL_curcop, oldline); } } 273146 if (!other) ###### return first; 273146 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) 9327 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ 273146 NewOp(1101, logop, 1, LOGOP); 273146 logop->op_type = (OPCODE)type; 273146 logop->op_ppaddr = PL_ppaddr[type]; 273146 logop->op_first = first; 273146 logop->op_flags = flags | OPf_KIDS; 273146 logop->op_other = LINKLIST(other); 273146 logop->op_private = (U8)(1 | (flags >> 8)); /* establish postfix order */ 273146 logop->op_next = LINKLIST(first); 273146 first->op_next = (OP*)logop; 273146 first->op_sibling = other; 273146 CHECKOP(type,logop); 273146 o = newUNOP(OP_NULL, 0, (OP*)logop); 273146 other->op_next = o; 273146 return o; } OP * Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) 121766 { dVAR; 121766 LOGOP *logop; 121766 OP *start; 121766 OP *o; 121766 if (!falseop) 53039 return newLOGOP(OP_AND, 0, first, trueop); 68727 if (!trueop) ###### return newLOGOP(OP_OR, 0, first, falseop); 68727 scalarboolean(first); 68727 if (first->op_type == OP_CONST) { 1 if (first->op_private & OPpCONST_BARE && first->op_private & OPpCONST_STRICT) { ###### no_bareword_allowed(first); } 1 if (SvTRUE(((SVOP*)first)->op_sv)) { 1 op_free(first); 1 op_free(falseop); 1 return trueop; } else { ###### op_free(first); ###### op_free(trueop); ###### return falseop; } } 68726 NewOp(1101, logop, 1, LOGOP); 68726 logop->op_type = OP_COND_EXPR; 68726 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; 68726 logop->op_first = first; 68726 logop->op_flags = flags | OPf_KIDS; 68726 logop->op_private = (U8)(1 | (flags >> 8)); 68726 logop->op_other = LINKLIST(trueop); 68726 logop->op_next = LINKLIST(falseop); CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ 68726 logop); /* establish postfix order */ 68726 start = LINKLIST(first); 68726 first->op_next = (OP*)logop; 68726 first->op_sibling = trueop; 68726 trueop->op_sibling = falseop; 68726 o = newUNOP(OP_NULL, 0, (OP*)logop); 68726 trueop->op_next = falseop->op_next = o; 68726 o->op_next = start; 68726 return o; } OP * Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) 1502 { dVAR; 1502 LOGOP *range; 1502 OP *flip; 1502 OP *flop; 1502 OP *leftstart; 1502 OP *o; 1502 NewOp(1101, range, 1, LOGOP); 1502 range->op_type = OP_RANGE; 1502 range->op_ppaddr = PL_ppaddr[OP_RANGE]; 1502 range->op_first = left; 1502 range->op_flags = OPf_KIDS; 1502 leftstart = LINKLIST(left); 1502 range->op_other = LINKLIST(right); 1502 range->op_private = (U8)(1 | (flags >> 8)); 1502 left->op_sibling = right; 1502 range->op_next = (OP*)range; 1502 flip = newUNOP(OP_FLIP, flags, (OP*)range); 1502 flop = newUNOP(OP_FLOP, 0, flip); 1502 o = newUNOP(OP_NULL, 0, flop); 1502 linklist(flop); 1502 range->op_next = leftstart; 1502 left->op_next = flip; 1502 right->op_next = flop; 1502 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 1502 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); 1502 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 1502 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); 1502 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 1502 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 1502 flip->op_next = o; 1502 if (!flip->op_private || !flop->op_private) 1324 linklist(o); /* blow off optimizer unless constant */ 1502 return o; } OP * Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) 1638 { 1638 OP* listop; 1638 OP* o; 1638 const bool once = block && block->op_flags & OPf_SPECIAL && 1638 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); 1638 (void)debuggable; 1638 if (expr) { 1638 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) ###### return block; /* do {} while 0 does once */ 1638 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { 322 expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 1316 } else if (expr->op_flags & OPf_KIDS) { 1214 const OP *k1 = ((UNOP*)expr)->op_first; 1214 const OP *k2 = (k1) ? k1->op_sibling : NULL; 1214 switch (expr->op_type) { case OP_NULL: 400 if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) ###### expr = newUNOP(OP_DEFINED, 0, expr); ###### break; case OP_SASSIGN: 47 if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH) ###### expr = newUNOP(OP_DEFINED, 0, expr); break; } } } /* if block is null, the next append_elem() would put UNSTACK, a scalar * op, in listop. This is wrong. [perl #27024] */ 1638 if (!block) ###### block = newOP(OP_NULL, 0); 1638 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); 1638 o = new_logop(OP_AND, 0, &expr, &listop); 1638 if (listop) 1638 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); 1638 if (once && o != listop) 570 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; 1638 if (o == listop) ###### o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ 1638 o->op_flags |= flags; 1638 o = scope(o); 1638 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ 1638 return o; } OP * Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont, I32 has_my) 30083 { dVAR; 30083 OP *redo; 30083 OP *next = 0; 30083 OP *listop; 30083 OP *o; 30083 U8 loopflags = 0; 30083 (void)debuggable; 30083 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { 567 expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 29516 } else if (expr && (expr->op_flags & OPf_KIDS)) { 4776 const OP *k1 = ((UNOP*)expr)->op_first; 4776 const OP *k2 = (k1) ? k1->op_sibling : NULL; 4776 switch (expr->op_type) { ca