This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add &CORE::pos
authorFather Chrysostomos <sprout@cpan.org>
Mon, 30 Apr 2012 04:15:25 +0000 (21:15 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 29 May 2012 16:36:26 +0000 (09:36 -0700)
gv.c
op.c
pp.c
t/op/coreamp.t
t/op/coresubs.t

diff --git a/gv.c b/gv.c
index 5185af8..87a8981 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -466,7 +466,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
     case KEY_gt   : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
     case KEY_local: case KEY_lt: case KEY_m   : case KEY_map : case KEY_my:
     case KEY_ne   : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
-    case KEY_package: case KEY_pos: case KEY_print  : case KEY_printf:
+    case KEY_package: case KEY_print: case KEY_printf:
     case KEY_prototype: case KEY_q: case KEY_qq: case KEY_qr: case KEY_qw:
     case KEY_qx   : case KEY_redo : case KEY_require: case KEY_return:
     case KEY_s    : case KEY_say  : case KEY_scalar : case KEY_sort  :
@@ -542,7 +542,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
                   1
        );
        assert(GvCV(gv) == cv);
-       if (opnum != OP_VEC && opnum != OP_SUBSTR)
+       if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS)
            CvLVALUE_off(cv); /* Now *that* was a neat trick. */
        LEAVE;
        PL_parser = oldparser;
diff --git a/op.c b/op.c
index c1424d0..697769c 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2022,6 +2022,9 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
        if (type != OP_LEAVESUBLV)
            goto nomod;
        break; /* op_lvalue()ing was handled by ck_return() */
+
+    case OP_COREARGS:
+       return o;
     }
 
     /* [20011101.069] File test operators interpret OPf_REF to mean that
@@ -2062,8 +2065,7 @@ S_scalar_mod_type(const OP *o, I32 type)
     switch (type) {
     case OP_POS:
     case OP_SASSIGN:
-       assert(o);
-       if (o->op_type == OP_RV2GV)
+       if (o && o->op_type == OP_RV2GV)
            return FALSE;
        /* FALL THROUGH */
     case OP_PREINC:
@@ -8088,7 +8090,8 @@ Perl_ck_fun(pTHX_ OP *o)
                scalar(kid);
                break;
            case OA_SCALARREF:
-               if (type == OP_UNDEF && numargs == 1 && !(oa >> 4)
+               if ((type == OP_UNDEF || type == OP_POS)
+                   && numargs == 1 && !(oa >> 4)
                    && kid->op_type == OP_LIST)
                    return too_many_arguments_pv(o,PL_op_desc[type], 0);
                op_lvalue(scalar(kid), type);
@@ -10687,14 +10690,14 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
          onearg:
              if (is_handle_constructor(o, 1))
                argop->op_private |= OPpCOREARGS_DEREF1;
+             if (scalar_mod_type(NULL, opnum))
+               argop->op_private |= OPpCOREARGS_SCALARMOD;
            }
            return o;
        default:
            o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
            if (is_handle_constructor(o, 2))
                argop->op_private |= OPpCOREARGS_DEREF2;
-           if (scalar_mod_type(NULL, opnum))
-               argop->op_private |= OPpCOREARGS_SCALARMOD;
            if (opnum == OP_SUBSTR) {
                o->op_private |= OPpMAYBE_LVSUB;
                return o;
diff --git a/pp.c b/pp.c
index b1ab8b9..c89b083 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -5934,6 +5934,7 @@ PP(pp_coreargs)
        whicharg++;
        switch (oa & 7) {
        case OA_SCALAR:
+         try_defsv:
            if (!numargs && defgv && whicharg == minargs + 1) {
                PERL_SI * const oldsi = PL_curstackinfo;
                I32 const oldcxix = oldsi->si_cxix;
@@ -5981,7 +5982,8 @@ PP(pp_coreargs)
            }
            break;
        case OA_SCALARREF:
-         {
+         if (!numargs) goto try_defsv;
+         else {
            const bool wantscalar =
                PL_op->op_private & OPpCOREARGS_SCALARMOD;
            if (!svp || !*svp || !SvROK(*svp)
@@ -6005,8 +6007,8 @@ PP(pp_coreargs)
                       : "reference to one of [$@%*]"
                );
            PUSHs(SvRV(*svp));
-           break;
          }
+         break;
        default:
            DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
        }
index 79af783..1e9147b 100644 (file)
@@ -28,6 +28,7 @@ package sov {
 my %op_desc = (
  evalbytes=> 'eval "string"',
  join     => 'join or string',
+ pos      => 'match position',
  readline => '<HANDLE>',
  readpipe => 'quoted execution (``, qx)',
  reset    => 'symbol reset',
@@ -222,6 +223,23 @@ sub test_proto {
         "&$o with coderef arg";
     }    
   }
+  elsif ($p eq ';\[$*]') {
+    $tests += 4;
+
+    my $desc = quotemeta op_desc($o);
+    eval " &CORE::$o(1,2) ";
+    like $@, qr/^Too many arguments for $desc at /,
+        "&$o with too many args";
+    eval " &CORE::$o([]) ";
+    like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /,
+        "&$o with array ref arg";
+    eval " &CORE::$o(1) ";
+    like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /,
+        "&$o with scalar arg";
+    eval " &CORE::$o(bless([], 'sov')) ";
+    like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /,
+        "&$o with non-scalar arg w/scalar overload (which does not count)";
+  }
 
   else {
     die "Please add tests for the $p prototype";
@@ -585,6 +603,23 @@ is &mypack("H*", '5065726c'), 'Perl', '&pack';
 lis [&mypack("H*", '5065726c')], ['Perl'], '&pack in list context';
 
 test_proto 'pipe';
+
+test_proto 'pos';
+$tests += 4;
+$_ = "hello";
+pos = 3;
+is &mypos, 3, 'reading &pos without args';
+&mypos = 4;
+is pos, 4, 'writing to &pos without args';
+{
+  my $x = "gubai";
+  pos $x = 3;
+  is &mypos(\$x), 3, 'reading &pos without args';
+  &mypos(\$x) = 4;
+  is pos $x, 4, 'writing to &pos without args';
+}
+
+
 test_proto 'quotemeta', '$', '\$';
 
 test_proto 'rand';
@@ -901,7 +936,7 @@ like $@, qr'^Undefined format "STDOUT" called',
       next if
        $word =~ /^(?:s(?:t(?:ate|udy)|(?:pli|or)t|calar|ay|ub)?|d(?:ef
                   ault|ump|o)|p(?:r(?:ototype|intf?)|ackag
-                  e|os)|e(?:ls(?:if|e)|val|q)|g(?:[et]|iven|oto
+                  e)|e(?:ls(?:if|e)|val|q)|g(?:[et]|iven|oto
                   |rep)|u(?:n(?:less|def|til)|se)|l(?:(?:as)?t|ocal|e)|re
                   (?:quire|turn|do)|__(?:DATA|END)__|for(?:each|mat)?|(?:
                   AUTOLOA|EN)D|n(?:e(?:xt)?|o)|C(?:HECK|ORE)|wh(?:ile|en)
index e6fcbd9..8fcdb14 100644 (file)
@@ -19,7 +19,7 @@ my %unsupported = map +($_=>1), qw (
  __DATA__ __END__ AUTOLOAD BEGIN UNITCHECK CORE DESTROY END INIT CHECK and
   cmp default do dump else elsif eq eval for foreach
   format ge given goto grep gt if last le local lt m map my ne next
-  no or our package pos print printf prototype q qq qr qw qx redo  require
+  no or our package print printf prototype q qq qr qw qx  redo  require
   return s say scalar sort split state study sub tr undef unless until use
   when while x xor y
 );
@@ -29,6 +29,9 @@ my %args_for = (
   delete   => '$1[2]',
   exists   => '$1[2]',
 );
+my %desc = (
+  pos => 'match position',
+);
 
 use File::Spec::Functions;
 my $keywords_file = catfile(updir,'regen','keywords.pl');
@@ -109,7 +112,8 @@ while(<$kh>) {
                )
        . "))}";
       eval $code;
-      like $@, qr/^Too many arguments for $word/,
+      my $desc = $desc{$word} || $word;
+      like $@, qr/^Too many arguments for $desc/,
           "inlined CORE::$word with too many args"
         or warn $code;