IO::Socket now sets $!, avoids eval/die (patch from Graham Barr

[p5sagit/p5-mst-13.2.git] / op.c

diff --git a/op.c b/op.c
index bc30f01..eb60ec1 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1412,18 +1412,19 @@ Perl_mod(pTHX_ OP *o, I32 type)
                    if (kid->op_type == OP_METHOD_NAMED
                        || kid->op_type == OP_METHOD)
                    {
-                       OP *newop;
+                       UNOP *newop;
 
                        if (kid->op_sibling || kid->op_next != kid) {
                            yyerror("panic: unexpected optree near method call");
                            break;
                        }
                        
-                       NewOp(1101, newop, 1, OP);
+                       NewOp(1101, newop, 1, UNOP);
                        newop->op_type = OP_RV2CV;
                        newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
-                       newop->op_next = newop;
-                       kid->op_sibling = newop;
+                       newop->op_first = Nullop;
+                        newop->op_next = (OP*)newop;
+                       kid->op_sibling = (OP*)newop;
                        newop->op_private |= OPpLVAL_INTRO;
                        break;
                    }
@@ -3514,9 +3515,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
        }
     }
     if (first->op_type == OP_CONST) {
-       if (ckWARN(WARN_PRECEDENCE) && (first->op_private & OPpCONST_BARE))
-           Perl_warner(aTHX_ WARN_PRECEDENCE, "Probable precedence problem on %s", 
-                       PL_op_desc[type]);
+       if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
+           Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
        if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
            op_free(first);
            *firstp = Nullop;
@@ -6458,11 +6458,12 @@ Perl_peep(pTHX_ register OP *o)
            UNOP *rop;
            SV *lexname;
            GV **fields;
-           SV **svp, **indsvp;
+           SV **svp, **indsvp, *sv;
            I32 ind;
            char *key;
            STRLEN keylen;
        
+           o->op_seq = PL_op_seqmax++;
            if ((o->op_private & (OPpLVAL_INTRO))
                || ((BINOP*)o)->op_last->op_type != OP_CONST)
                break;
@@ -6489,8 +6490,76 @@ Perl_peep(pTHX_ register OP *o)
            rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
            o->op_type = OP_AELEM;
            o->op_ppaddr = PL_ppaddr[OP_AELEM];
+           sv = newSViv(ind);
+           if (SvREADONLY(*svp))
+               SvREADONLY_on(sv);
+           SvFLAGS(sv) |= (SvFLAGS(*svp)
+                           & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
            SvREFCNT_dec(*svp);
-           *svp = newSViv(ind);
+           *svp = sv;
+           break;
+       }
+       
+       case OP_HSLICE: {
+           UNOP *rop;
+           SV *lexname;
+           GV **fields;
+           SV **svp, **indsvp, *sv;
+           I32 ind;
+           char *key;
+           STRLEN keylen;
+           SVOP *first_key_op, *key_op;
+
+           o->op_seq = PL_op_seqmax++;
+           if ((o->op_private & (OPpLVAL_INTRO))
+               /* I bet there's always a pushmark... */
+               || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
+               /* hmmm, no optimization if list contains only one key. */
+               break;
+           rop = (UNOP*)((LISTOP*)o)->op_last;
+           if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
+               break;
+           lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
+           if (!SvOBJECT(lexname))
+               break;
+           fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+           if (!fields || !GvHV(*fields))
+               break;
+           /* Again guessing that the pushmark can be jumped over.... */
+           first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
+               ->op_first->op_sibling;
+           /* Check that the key list contains only constants. */
+           for (key_op = first_key_op; key_op;
+                key_op = (SVOP*)key_op->op_sibling)
+               if (key_op->op_type != OP_CONST)
+                   break;
+           if (key_op)
+               break;
+           rop->op_type = OP_RV2AV;
+           rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
+           o->op_type = OP_ASLICE;
+           o->op_ppaddr = PL_ppaddr[OP_ASLICE];
+           for (key_op = first_key_op; key_op;
+                key_op = (SVOP*)key_op->op_sibling) {
+               svp = cSVOPx_svp(key_op);
+               key = SvPV(*svp, keylen);
+               indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
+               if (!indsvp) {
+                   Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
+                              "in variable %s of type %s",
+                         key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
+               }
+               ind = SvIV(*indsvp);
+               if (ind < 1)
+                   Perl_croak(aTHX_ "Bad index while coercing array into hash");
+               sv = newSViv(ind);
+               if (SvREADONLY(*svp))
+                   SvREADONLY_on(sv);
+               SvFLAGS(sv) |= (SvFLAGS(*svp)
+                               & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
+               SvREFCNT_dec(*svp);
+               *svp = sv;
+           }
            break;
        }