&CORE::select()

This commit allows CORE::select to be called through references and
via &ampersand syntax.

This is a tricky case, as the select keyword represents two distinct
operators.  ck_select replaces the OP_SELECT with an OP_SSELECT if
there is more that one argument.

So what we do here is create an if(@_>1)/else block with the usual
op-with-coreargs-child inside each branch.

The op tree looks like this:

$ ./perl -Ilib -mO=Concise,CORE::select -e 'BEGIN{\&CORE::select}
'
CORE::select:
8  <1> leavesub[1 ref] K/REFC,1 ->(end)
-     <1> null K/1 ->8
5        <|> cond_expr(other->6) K/1 ->9
4           <2> gt sK/2 ->5
2              <1> rv2av[t4] sK/1 ->3
1                 <#> gv[*_] s ->2
3              <$> const[IV 1] s ->4
7           <@> sselect[t2] K ->8
-              <0> ex-pushmark s ->6
6              <$> coreargs(IV 218) ->7
a           <@> select[t1] sK/1 ->8
-              <0> ex-pushmark s ->9
9              <$> coreargs(IV 219) s/DREF1 ->a
-e syntax OK

There was no need to modify pp_select to handle a null when there is
no argument, as it can already handle it.

diff --git a/gv.c b/gv.c
index b9516d8..e3bc866 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1358,7 +1358,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            case KEY_lstat:
            case KEY_pop:
            case KEY_push:
-           case KEY_select: case KEY_send:
+           case KEY_send:
            case KEY_setpgrp: case KEY_shift: case KEY_sleep:
            case KEY_splice:
            case KEY_srand: case KEY_stat: case KEY_substr:

diff --git a/op.c b/op.c
index 73dccf8..6d781ba 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10361,6 +10361,19 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
                                  newOP(OP_CALLER,0)
                       )
               );
+    case OP_SELECT: /* which represents OP_SSELECT as well */
+       if (code)
+           return newCONDOP(
+                        0,
+                        newBINOP(OP_GT, 0,
+                                 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
+                                 newSVOP(OP_CONST, 0, newSVuv(1))
+                                ),
+                        coresub_op(newSVuv((UV)OP_SSELECT), 0,
+                                   OP_SSELECT),
+                        coresub_op(coreargssv, 0, OP_SELECT)
+                  );
+       /* FALL THROUGH */
     default:
        switch (PL_opargs[opnum] & OA_CLASS_MASK) {
        case OA_BASEOP:

diff --git a/t/op/coreamp.t b/t/op/coreamp.t
index 37802bd..cff1487 100644 (file)
--- a/t/op/coreamp.t
+++ b/t/op/coreamp.t
@@ -617,6 +617,33 @@ test_proto 'seek';
 }
 
 test_proto 'seekdir';
+
+# Can’t test_proto, as it has none
+$tests += 8;
+*myselect = \&CORE::select;
+is defined prototype &myselect, defined prototype "CORE::select",
+   'prototype of &select (or lack thereof)';
+is &myselect, select, '&select with no args';
+{
+  my $prev = select;
+  is &myselect(my $fh), $prev, '&select($arg) retval';
+  is lc ref $fh, 'glob', '&select autovivifies';
+  is select=~s/\*//rug, (*$fh."")=~s/\*//rug, '&select selects';
+  select $prev;
+}
+eval { &myselect(1,2) };
+like $@, qr/^Not enough arguments for select system call at /,
+      ,'&myselect($two,$args)';
+eval { &myselect(1,2,3) };
+like $@, qr/^Not enough arguments for select system call at /,
+      ,'&myselect($with,$three,$args)';
+eval { &myselect(1,2,3,4,5) };
+like $@, qr/^Too many arguments for select system call at /,
+      ,'&myselect($a,$total,$of,$five,$args)';
+&myselect((undef)x3,.25);
+# Just have to assume that worked. :-) If we get here, at least it didn’t
+# crash or anything.
+
 test_proto "sem$_" for qw "ctl get op";
 
 test_proto "set$_" for qw '