&CORE::bless()

This commit allows &CORE::bless to be called through references and
via ampersand syntax.  pp_bless is modified to take into account the
nulls pushed on to the stack in pp_coreargs, since pp_coreargs has no
other way to tell bless how many arguments it’s actually getting.

diff --git a/gv.c b/gv.c
index a9a1129..0bbf09e 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1351,7 +1351,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
            case KEY_or: case KEY_x: case KEY_xor:
                return gv;
-           case KEY_bless: case KEY_caller: case KEY_chdir:
+           case KEY_caller: case KEY_chdir:
            case KEY_chmod: case KEY_chomp: case KEY_chop: case KEY_chown:
            case KEY_close:
            case KEY_dbmclose: case KEY_dbmopen: case KEY_die:

diff --git a/pp.c b/pp.c
index 302b5cc..04e4e4a 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -590,13 +590,15 @@ PP(pp_bless)
     HV *stash;
 
     if (MAXARG == 1)
+      curstash:
        stash = CopSTASH(PL_curcop);
     else {
        SV * const ssv = POPs;
        STRLEN len;
        const char *ptr;
 
-       if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
+       if (!ssv) goto curstash;
+       if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
            Perl_croak(aTHX_ "Attempt to bless into a reference");
        ptr = SvPV_const(ssv,len);
        if (len == 0)

diff --git a/t/op/coresubs.t b/t/op/coresubs.t
index 9573e1f..9a615fc 100644 (file)
--- a/t/op/coresubs.t
+++ b/t/op/coresubs.t
@@ -165,6 +165,13 @@ is &CORE::binmode(qw[foo bar]), undef, "&binmode";
 lis [&CORE::binmode(qw[foo bar])], [undef], "&binmode in list context";
 is &mybinmode(foo), undef, '&binmode with one arg';
 
+test_proto 'bless';
+$tests += 3;
+like &CORE::bless([],'parcel'), qr/^parcel=ARRAY/, "&bless";
+like join(" ", &CORE::bless([],'parcel')),
+     qr/^parcel=ARRAY(?!.* )/, "&bless in list context";
+like &mybless([]), qr/^main=ARRAY/, '&bless with one arg';
+
 test_proto 'break';
 { $tests ++;
   my $tmp;