X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=3dd0cdbb94c201ee83654d66fe6ee78f783d3d8b;hb=27cec4bd74b4c0ab87d3b49d275b8814f59e9bfc;hp=626db8f54846b6f466755beda450f20cc48a9aea;hpb=ff7298cbf9257c89a24403f4c51889c5bc71c44c;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/op.c b/op.c
index 626db8f..3dd0cdb 100644
--- a/op.c
+++ b/op.c
@@ -820,6 +820,8 @@ Perl_scalarvoid(pTHX_ OP *o)
     case OP_AND:
     case OP_DOR:
     case OP_COND_EXPR:
+    case OP_ENTERGIVEN:
+    case OP_ENTERWHEN:
 	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 	    scalarvoid(kid);
 	break;
@@ -841,6 +843,8 @@ Perl_scalarvoid(pTHX_ OP *o)
     case OP_LEAVELOOP:
     case OP_LINESEQ:
     case OP_LIST:
+    case OP_LEAVEGIVEN:
+    case OP_LEAVEWHEN:
 	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 	    scalarvoid(kid);
 	break;
@@ -3918,6 +3922,8 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP
 	    iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
 	    sv->op_type = OP_RV2GV;
 	    sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
+	    if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
+		iterpflags |= OPpITER_DEF;
 	}
 	else if (sv->op_type == OP_PADSV) { /* private variable */
 	    iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
@@ -3935,6 +3941,8 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP
 	}
 	else
 	    Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
+	if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
+	    iterpflags |= OPpITER_DEF;
     }
     else {
         const I32 offset = pad_findmy("$_");
@@ -3944,6 +3952,7 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP
 	else {
 	    padoff = offset;
 	}
+	iterpflags |= OPpITER_DEF;
     }
     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
 	expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
@@ -4031,6 +4040,177 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label)
     return o;
 }
 
+/* if the condition is a literal array or hash
+   (or @{ ... } etc), make a reference to it.
+ */
+STATIC OP *
+S_ref_array_or_hash(pTHX_ OP *cond)
+{
+    if (cond
+    && (cond->op_type == OP_RV2AV
+    ||  cond->op_type == OP_PADAV
+    ||  cond->op_type == OP_RV2HV
+    ||  cond->op_type == OP_PADHV))
+
+	return newUNOP(OP_REFGEN,
+	    0, mod(cond, OP_REFGEN));
+
+    else
+	return cond;
+}
+
+/* These construct the optree fragments representing given()
+   and when() blocks.
+
+   entergiven and enterwhen are LOGOPs; the op_other pointer
+   points up to the associated leave op. We need this so we
+   can put it in the context and make break/continue work.
+   (Also, of course, pp_enterwhen will jump straight to
+   op_other if the match fails.)
+ */
+
+STATIC
+OP *
+S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
+		   I32 enter_opcode, I32 leave_opcode,
+		   PADOFFSET entertarg)
+{
+    LOGOP *enterop;
+    OP *o;
+
+    NewOp(1101, enterop, 1, LOGOP);
+    enterop->op_type = enter_opcode;
+    enterop->op_ppaddr = PL_ppaddr[enter_opcode];
+    enterop->op_flags =  (U8) OPf_KIDS;
+    enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
+    enterop->op_private = 0;
+
+    o = newUNOP(leave_opcode, 0, (OP *) enterop);
+
+    if (cond) {
+	enterop->op_first = scalar(cond);
+	cond->op_sibling = block;
+
+	o->op_next = LINKLIST(cond);
+	cond->op_next = (OP *) enterop;
+    }
+    else {
+	/* This is a default {} block */
+	enterop->op_first = block;
+	enterop->op_flags |= OPf_SPECIAL;
+
+	o->op_next = (OP *) enterop;
+    }
+
+    CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
+    				       entergiven and enterwhen both
+    				       use ck_null() */
+
+    enterop->op_next = LINKLIST(block);
+    block->op_next = enterop->op_other = o;
+
+    return o;
+}
+
+/* Does this look like a boolean operation? For these purposes
+   a boolean operation is:
+     - a subroutine call [*]
+     - a logical connective
+     - a comparison operator
+     - a filetest operator, with the exception of -s -M -A -C
+     - defined(), exists() or eof()
+     - /$re/ or $foo =~ /$re/
+   
+   [*] possibly surprising
+ */
+STATIC
+bool
+S_looks_like_bool(pTHX_ OP *o)
+{
+    switch(o->op_type) {
+	case OP_OR:
+	    return looks_like_bool(cLOGOPo->op_first);
+
+	case OP_AND:
+	    return (
+	    	looks_like_bool(cLOGOPo->op_first)
+	     && looks_like_bool(cLOGOPo->op_first->op_sibling));
+
+	case OP_ENTERSUB:
+
+	case OP_NOT:	case OP_XOR:
+	/* Note that OP_DOR is not here */
+
+	case OP_EQ:	case OP_NE:	case OP_LT:
+	case OP_GT:	case OP_LE:	case OP_GE:
+
+	case OP_I_EQ:	case OP_I_NE:	case OP_I_LT:
+	case OP_I_GT:	case OP_I_LE:	case OP_I_GE:
+
+	case OP_SEQ:	case OP_SNE:	case OP_SLT:
+	case OP_SGT:	case OP_SLE:	case OP_SGE:
+	
+	case OP_SMARTMATCH:
+	
+	case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
+	case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
+	case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
+	case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
+	case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
+	case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
+	case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
+	case OP_FTTEXT:   case OP_FTBINARY:
+	
+	case OP_DEFINED: case OP_EXISTS:
+	case OP_MATCH:	 case OP_EOF:
+
+	    return TRUE;
+	
+	case OP_CONST:
+	    /* Detect comparisons that have been optimized away */
+	    if (cSVOPo->op_sv == &PL_sv_yes
+	    ||  cSVOPo->op_sv == &PL_sv_no)
+	    
+		return TRUE;
+		
+	/* FALL THROUGH */
+	default:
+	    return FALSE;
+    }
+}
+
+OP *
+Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
+{
+    assert( cond );
+    return newGIVWHENOP(
+    	ref_array_or_hash(cond),
+    	block,
+	OP_ENTERGIVEN, OP_LEAVEGIVEN,
+	defsv_off);
+}
+
+/* If cond is null, this is a default {} block */
+OP *
+Perl_newWHENOP(pTHX_ OP *cond, OP *block)
+{
+    bool cond_llb = (!cond || looks_like_bool(cond));
+    OP *cond_op;
+
+    if (cond_llb)
+	cond_op = cond;
+    else {
+	cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
+		newDEFSVOP(),
+		scalar(ref_array_or_hash(cond)));
+    }
+    
+    return newGIVWHENOP(
+	cond_op,
+	append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
+	OP_ENTERWHEN, OP_LEAVEWHEN, 0);
+}
+
 /*
 =for apidoc cv_undef
 
@@ -5104,6 +5284,13 @@ Perl_ck_eval(pTHX_ OP *o)
 	o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
     }
     o->op_targ = (PADOFFSET)PL_hints;
+    if ((PL_hints & HINT_HH_FOR_EVAL) != 0 && GvHV(PL_hintgv))
+    {
+	/* Store a copy of %^H that pp_entereval can pick up */
+	OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
+	cUNOPo->op_first->op_sibling = hhop;
+	o->op_private |= OPpEVAL_HAS_HH;
+    }
     return o;
 }
 
@@ -5763,6 +5950,43 @@ Perl_ck_listiob(pTHX_ OP *o)
 }
 
 OP *
+Perl_ck_say(pTHX_ OP *o)
+{
+    o = ck_listiob(o);
+    o->op_type = OP_PRINT;
+    cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
+    	= newSVOP(OP_CONST, 0, newSVpvn("\n", 1));
+    return o;
+}
+
+OP *
+Perl_ck_smartmatch(pTHX_ OP *o)
+{
+    if (0 == (o->op_flags & OPf_SPECIAL)) {
+	OP *first  = cBINOPo->op_first;
+	OP *second = first->op_sibling;
+	
+	/* Implicitly take a reference to an array or hash */
+	first->op_sibling = Nullop;
+	first = cBINOPo->op_first = ref_array_or_hash(first);
+	second = first->op_sibling = ref_array_or_hash(second);
+	
+	/* Implicitly take a reference to a regular expression */
+	if (first->op_type == OP_MATCH) {
+	    first->op_type = OP_QR;
+	    first->op_ppaddr = PL_ppaddr[OP_QR];
+	}
+	if (second->op_type == OP_MATCH) {
+	    second->op_type = OP_QR;
+	    second->op_ppaddr = PL_ppaddr[OP_QR];
+        }
+    }
+    
+    return o;
+}
+
+
+OP *
 Perl_ck_sassign(pTHX_ OP *o)
 {
     OP *kid = cLISTOPo->op_first;
@@ -5795,7 +6019,7 @@ Perl_ck_sassign(pTHX_ OP *o)
 OP *
 Perl_ck_match(pTHX_ OP *o)
 {
-    if (o->op_type != OP_QR) {
+    if (o->op_type != OP_QR && PL_compcv) {
 	const I32 offset = pad_findmy("$_");
 	if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
 	    o->op_targ = offset;
@@ -6007,6 +6231,21 @@ Perl_ck_sort(pTHX_ OP *o)
 {
     OP *firstkid;
 
+    if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
+    {
+	HV *hinthv = GvHV(PL_hintgv);
+	if (hinthv) {
+	    SV **svp = hv_fetch(hinthv, "sort", 4, 0);
+	    if (svp) {
+		I32 sorthints = (I32)SvIV(*svp);
+		if ((sorthints & HINT_SORT_QUICKSORT) != 0)
+		    o->op_private |= OPpSORT_QSORT;
+		if ((sorthints & HINT_SORT_STABLE) != 0)
+		    o->op_private |= OPpSORT_STABLE;
+	    }
+	}
+    }
+
     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
 	simplify_sort(o);
     firstkid = cLISTOPo->op_first->op_sibling;		/* get past pushmark */