The exact error message is system-dependent.

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

diff --git a/op.c b/op.c
index b19abea..eba48b9 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2155,7 +2155,10 @@ OP*
 Perl_block_end(pTHX_ I32 floor, OP *seq)
 {
     int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
-    OP* retval = scalarseq(seq);
+    line_t copline = PL_copline;
+    /* there should be a nextstate in every block */
+    OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
+    PL_copline = copline;  /* XXX newSTATEOP may reset PL_copline */
     LEAVE_SCOPE(floor);
     PL_pad_reset_pending = FALSE;
     PL_compiling.op_private = PL_hints;
@@ -4515,7 +4518,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
     }
 }
 
-static void const_sv_xsub(pTHXo_ CV* cv);
+static void const_sv_xsub(pTHX_ CV* cv);
 
 /*
 =for apidoc cv_const_sv
@@ -4704,7 +4707,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                        && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
                {
                    line_t oldline = CopLINE(PL_curcop);
-                   CopLINE_set(PL_curcop, PL_copline);
+                   if (PL_copline != NOLINE)
+                       CopLINE_set(PL_curcop, PL_copline);
                    Perl_warner(aTHX_ WARN_REDEFINE,
                        CvCONST(cv) ? "Constant subroutine %s redefined"
                                    : "Subroutine %s redefined", name);
@@ -5177,8 +5181,8 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
     if ((cv = GvFORM(gv))) {
        if (ckWARN(WARN_REDEFINE)) {
            line_t oldline = CopLINE(PL_curcop);
-
-           CopLINE_set(PL_curcop, PL_copline);
+           if (PL_copline != NOLINE)
+               CopLINE_set(PL_curcop, PL_copline);
            Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
            CopLINE_set(PL_curcop, oldline);
        }
@@ -6541,6 +6545,8 @@ Perl_ck_subr(pTHX_ OP *o)
     GV *namegv = 0;
     int optional = 0;
     I32 arg = 0;
+    I32 contextclass = 0;
+    char *e = 0;
     STRLEN n_a;
 
     o->op_private |= OPpENTERSUB_HASTARG;
@@ -6637,36 +6643,67 @@ Perl_ck_subr(pTHX_ OP *o)
                }
                scalar(o2);
                break;
+           case '[': case ']':
+                goto oops;
+                break;
            case '\\':
                proto++;
                arg++;
+           again:
                switch (*proto++) {
+               case '[':
+                    if (contextclass++ == 0) {
+                         e = strchr(proto, ']');
+                         if (!e || e == proto)
+                              goto oops;
+                    }
+                    else
+                         goto oops;
+                    goto again;
+                    break;
+               case ']':
+                    if (contextclass)
+                         contextclass = 0;
+                    else
+                         goto oops;
+                    break;
                case '*':
-                   if (o2->op_type != OP_RV2GV)
-                       bad_type(arg, "symbol", gv_ename(namegv), o2);
-                   goto wrapref;
+                    if (o2->op_type == OP_RV2GV)
+                         goto wrapref;
+                    if (!contextclass)
+                         bad_type(arg, "symbol", gv_ename(namegv), o2);
+                    break;
                case '&':
-                   if (o2->op_type != OP_ENTERSUB)
-                       bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
-                   goto wrapref;
+                    if (o2->op_type == OP_ENTERSUB)
+                         goto wrapref;
+                    if (!contextclass)
+                         bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
+                    break;
                case '$':
-                   if (o2->op_type != OP_RV2SV
-                       && o2->op_type != OP_PADSV
-                       && o2->op_type != OP_HELEM
-                       && o2->op_type != OP_AELEM
-                       && o2->op_type != OP_THREADSV)
-                   {
+                   if (o2->op_type == OP_RV2SV ||
+                       o2->op_type == OP_PADSV ||
+                       o2->op_type == OP_HELEM ||
+                       o2->op_type == OP_AELEM ||
+                       o2->op_type == OP_THREADSV)
+                        goto wrapref;
+                   if (!contextclass)
                        bad_type(arg, "scalar", gv_ename(namegv), o2);
-                   }
-                   goto wrapref;
+                    break;
                case '@':
-                   if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
+                   if (o2->op_type == OP_RV2AV ||
+                       o2->op_type == OP_PADAV)
+                        goto wrapref;
+                   if (!contextclass)
                        bad_type(arg, "array", gv_ename(namegv), o2);
-                   goto wrapref;
+                   break;
                case '%':
-                   if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
-                       bad_type(arg, "hash", gv_ename(namegv), o2);
-                 wrapref:
+                   if (o2->op_type == OP_RV2HV ||
+                       o2->op_type == OP_PADHV)
+                        goto wrapref;
+                   if (!contextclass)
+                        bad_type(arg, "hash", gv_ename(namegv), o2);
+                   break;
+               wrapref:
                    {
                        OP* kid = o2;
                        OP* sib = kid->op_sibling;
@@ -6675,9 +6712,15 @@ Perl_ck_subr(pTHX_ OP *o)
                        o2->op_sibling = sib;
                        prev->op_sibling = o2;
                    }
+                   if (contextclass && e) {
+                        proto = e + 1;
+                        contextclass = 0;
+                   }
                    break;
                default: goto oops;
                }
+               if (contextclass)
+                    goto again;
                break;
            case ' ':
                proto++;
@@ -6685,7 +6728,7 @@ Perl_ck_subr(pTHX_ OP *o)
            default:
              oops:
                Perl_croak(aTHX_ "Malformed prototype for %s: %s",
-                       gv_ename(namegv), SvPV((SV*)cv, n_a));
+                          gv_ename(namegv), SvPV((SV*)cv, n_a));
            }
        }
        else
@@ -7142,7 +7185,7 @@ char* custom_op_desc(pTHX_ OP* o)
 
 /* Efficient sub that returns a constant scalar value. */
 static void
-const_sv_xsub(pTHXo_ CV* cv)
+const_sv_xsub(pTHX_ CV* cv)
 {
     dXSARGS;
     if (items != 0) {