Add builtin::blessed, refaddr and reftype

13 files changed, 177 insertions, 5 deletions

diff --git a/builtin.c b/builtin.c
index 5a62a12bb9..5ef3a0bdfd 100644
--- a/builtin.c
+++ b/builtin.c
@@ -89,6 +89,18 @@ XS(XS_builtin_func1_scalar)
             Perl_pp_isweak(aTHX);
             break;
 
+        case OP_BLESSED:
+            Perl_pp_blessed(aTHX);
+            break;
+
+        case OP_REFADDR:
+            Perl_pp_refaddr(aTHX);
+            break;
+
+        case OP_REFTYPE:
+            Perl_pp_reftype(aTHX);
+            break;
+
         default:
             Perl_die(aTHX_ "panic: unhandled opcode %d for xs_builtin_func1_scalar()", ix);
     }
@@ -167,6 +179,9 @@ static const struct BuiltinFuncDescriptor builtins[] = {
     { "builtin::weaken",   &XS_builtin_func1_void,   &ck_builtin_func1, OP_WEAKEN   },
     { "builtin::unweaken", &XS_builtin_func1_void,   &ck_builtin_func1, OP_UNWEAKEN },
     { "builtin::isweak",   &XS_builtin_func1_scalar, &ck_builtin_func1, OP_ISWEAK   },
+    { "builtin::blessed",  &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED  },
+    { "builtin::refaddr",  &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR  },
+    { "builtin::reftype",  &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE  },
     { 0 }
 };
 
diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
index b4c321a306..a2b5621641 100644
--- a/ext/Opcode/Opcode.pm
+++ b/ext/Opcode/Opcode.pm
@@ -417,6 +417,7 @@ These are a hotchpotch of opcodes still waiting to be considered
     once
 
     rv2gv refgen srefgen ref refassign lvref lvrefslice lvavref
+    blessed refaddr reftype
 
     bless -- could be used to change ownership of objects
 	     (reblessing)
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index 14a13bcee4..eb4e1827fc 100644
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -6615,6 +6615,9 @@ sub pp_isbool   { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "isbool"); }
 sub pp_isweak   { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "isweak"); }
 sub pp_weaken   { builtin1(@_, "weaken"); }
 sub pp_unweaken { builtin1(@_, "unweaken"); }
+sub pp_blessed  { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "blessed"); }
+sub pp_refaddr  { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "refaddr"); }
+sub pp_reftype  { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "reftype"); }
 
 1;
 __END__
diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
index 9fafd84bf3..e6c01e3c80 100644
--- a/lib/B/Deparse.t
+++ b/lib/B/Deparse.t
@@ -3205,3 +3205,6 @@ $x = builtin::isbool(undef);
 $x = builtin::isweak(undef);
 builtin::weaken($x);
 builtin::unweaken($x);
+$x = builtin::blessed(undef);
+$x = builtin::refaddr(undef);
+$x = builtin::reftype(undef);
diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm
index 208ffe4bc0..b2faef915d 100644
--- a/lib/B/Op_private.pm
+++ b/lib/B/Op_private.pm
@@ -149,7 +149,7 @@ $bits{$_}{6} = 'OPpPAD_STATE' for qw(lvavref lvref padav padhv padsv pushmark re
 $bits{$_}{7} = 'OPpPV_IS_UTF8' for qw(dump goto last next redo);
 $bits{$_}{6} = 'OPpREFCOUNTED' for qw(leave leaveeval leavesub leavesublv leavewrite);
 $bits{$_}{2} = 'OPpSLICEWARNING' for qw(aslice hslice padav padhv rv2av rv2hv);
-$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int isbool isweak kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid);
+$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 blessed chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int isbool isweak kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand refaddr reftype rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid);
 $bits{$_}{0} = 'OPpTRANS_CAN_FORCE_UTF8' for qw(trans transr);
 $bits{$_}{5} = 'OPpTRANS_COMPLEMENT' for qw(trans transr);
 $bits{$_}{7} = 'OPpTRANS_DELETE' for qw(trans transr);
@@ -272,6 +272,7 @@ $bits{backtick}{0} = $bf[0];
 @{$bits{bind}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
 @{$bits{binmode}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
 @{$bits{bless}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
+$bits{blessed}{0} = $bf[0];
 @{$bits{caller}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
 $bits{catch}{0} = $bf[0];
 @{$bits{chdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@@ -482,8 +483,10 @@ $bits{readlink}{0} = $bf[0];
 @{$bits{recv}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
 $bits{redo}{0} = $bf[0];
 $bits{ref}{0} = $bf[0];
+$bits{refaddr}{0} = $bf[0];
 @{$bits{refassign}}{5,4,1,0} = ($bf[9], $bf[9], $bf[1], $bf[1]);
 $bits{refgen}{0} = $bf[0];
+$bits{reftype}{0} = $bf[0];
 $bits{regcmaybe}{0} = $bf[0];
 $bits{regcomp}{0} = $bf[0];
 $bits{regcreset}{0} = $bf[0];
@@ -841,7 +844,7 @@ our %ops_using = (
     OPpSORT_DESCEND          => [qw(sort)],
     OPpSPLIT_ASSIGN          => [qw(split)],
     OPpSUBSTR_REPL_FIRST     => [qw(substr)],
-    OPpTARGET_MY             => [qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int isbool isweak kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid)],
+    OPpTARGET_MY             => [qw(abs add atan2 blessed chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int isbool isweak kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand refaddr reftype rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid)],
     OPpTRANS_CAN_FORCE_UTF8  => [qw(trans transr)],
     OPpTRUEBOOL              => [qw(grepwhile index length padav padhv pos ref rindex rv2av rv2hv subst)],
     OPpUSEINT                => [qw(bit_and bit_or bit_xor complement left_shift nbit_and nbit_or nbit_xor ncomplement right_shift sbit_and sbit_or sbit_xor)],
diff --git a/lib/builtin.pm b/lib/builtin.pm
index dfde97fe99..baa7ec1931 100644
--- a/lib/builtin.pm
+++ b/lib/builtin.pm
@@ -19,6 +19,7 @@ builtin - Perl pragma to import built-in utility functions
     use builtin qw(
         true false isbool
         weaken unweaken isweak
+        blessed refaddr reftype
     );
 
 =head1 DESCRIPTION
@@ -120,6 +121,29 @@ Strengthens a reference, undoing the effects of a previous call to L</weaken>.
 Returns true when given a weakened reference, or false if not a reference or
 not weak.
 
+=head2 blessed
+
+    $str = blessed($ref);
+
+Returns the package name for an object reference, or C<undef> for a
+non-reference or reference that is not an object.
+
+=head2 refaddr
+
+    $num = refaddr($ref);
+
+Returns the memory address for a reference, or C<undef> for a non-reference.
+This value is not likely to be very useful for pure Perl code, but is handy as
+a means to test for referential identity or uniqueness.
+
+=head2 reftype
+
+    $str = reftype($ref);
+
+Returns the basic container type of the referent of a reference, or C<undef>
+for a non-reference. This is returned as a string in all-capitals, such as
+C<ARRAY> for array references, or C<HASH> for hash references.
+
 =head1 SEE ALSO
 
 L<perlop>, L<perlfunc>, L<Scalar::Util>
diff --git a/lib/builtin.t b/lib/builtin.t
index b94cef4e40..dec6b9eae2 100644
--- a/lib/builtin.t
+++ b/lib/builtin.t
@@ -66,7 +66,25 @@ package FetchStoreCounter {
 
     weaken($ref);
     undef $arr;
-    ok(!defined $ref, 'ref is now undef after arr is cleared');
+    is($ref, undef, 'ref is now undef after arr is cleared');
+}
+
+# reference queries
+{
+    use builtin qw( refaddr reftype blessed );
+
+    my $arr = [];
+    my $obj = bless [], "Object";
+
+    is(refaddr($arr),        $arr+0, 'refaddr yields same as ref in numeric context');
+    is(refaddr("not a ref"), undef,  'refaddr yields undef for non-reference');
+
+    is(reftype($arr),        "ARRAY", 'reftype yields type string');
+    is(reftype($obj),        "ARRAY", 'reftype yields basic container type for blessed object');
+    is(reftype("not a ref"), undef,   'reftype yields undef for non-reference');
+
+    is(blessed($arr), undef, 'blessed yields undef for non-object');
+    is(blessed($obj), "Object", 'blessed yields package name for object');
 }
 
 # imports are lexical; should not be visible here
diff --git a/opcode.h b/opcode.h
index 269030388c..9ea8ef142e 100644
--- a/opcode.h
+++ b/opcode.h
@@ -558,6 +558,9 @@ EXTCONST char* const PL_op_name[] = {
 	"isweak",
 	"weaken",
 	"unweaken",
+	"blessed",
+	"refaddr",
+	"reftype",
         "freed",
 };
 #endif
@@ -975,6 +978,9 @@ EXTCONST char* const PL_op_desc[] = {
 	"weakref type test",
 	"reference weaken",
 	"reference unweaken",
+	"blessed",
+	"refaddr",
+	"reftype",
         "freed op",
 };
 #endif
@@ -1395,6 +1401,9 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
 	Perl_pp_isweak,
 	Perl_pp_weaken,
 	Perl_pp_unweaken,
+	Perl_pp_blessed,
+	Perl_pp_refaddr,
+	Perl_pp_reftype,
 }
 #endif
 ;
@@ -1811,6 +1820,9 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
 	Perl_ck_null,		/* isweak */
 	Perl_ck_null,		/* weaken */
 	Perl_ck_null,		/* unweaken */
+	Perl_ck_null,		/* blessed */
+	Perl_ck_null,		/* refaddr */
+	Perl_ck_null,		/* reftype */
 }
 #endif
 ;
@@ -2228,6 +2240,9 @@ EXTCONST U32 PL_opargs[] = {
 	0x0000011e,	/* isweak */
 	0x00000100,	/* weaken */
 	0x00000100,	/* unweaken */
+	0x0000011e,	/* blessed */
+	0x0000011e,	/* refaddr */
+	0x0000011e,	/* reftype */
 };
 #endif
 
@@ -2902,6 +2917,9 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
       75, /* isweak */
        0, /* weaken */
        0, /* unweaken */
+      75, /* blessed */
+      75, /* refaddr */
+      75, /* reftype */
 
 };
 
@@ -2941,7 +2959,7 @@ EXTCONST U16  PL_op_private_bitdefs[] = {
     0x117c, 0x21b8, 0x09b4, 0x3fec, 0x2548, 0x4764, 0x07c1, /* trans, transr */
     0x0fbc, 0x04d8, 0x0067, /* sassign */
     0x0c78, 0x0b74, 0x0a70, 0x30cc, 0x05a8, 0x0067, /* aassign */
-    0x4530, 0x0003, /* chomp, schomp, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, ord, chr, chroot, rmdir, isbool, isweak */
+    0x4530, 0x0003, /* chomp, schomp, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, ord, chr, chroot, rmdir, isbool, isweak, blessed, refaddr, reftype */
     0x05b4, 0x30cc, 0x0003, /* pos */
     0x4530, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract */
     0x1538, 0x0067, /* repeat */
@@ -3409,6 +3427,9 @@ EXTCONST U8 PL_op_private_valid[] = {
     /* ISWEAK     */ (OPpARG1_MASK|OPpTARGET_MY),
     /* WEAKEN     */ (OPpARG1_MASK),
     /* UNWEAKEN   */ (OPpARG1_MASK),
+    /* BLESSED    */ (OPpARG1_MASK|OPpTARGET_MY),
+    /* REFADDR    */ (OPpARG1_MASK|OPpTARGET_MY),
+    /* REFTYPE    */ (OPpARG1_MASK|OPpTARGET_MY),
 
 };
 
diff --git a/opnames.h b/opnames.h
index 94a6b6c96d..cfad87aaf7 100644
--- a/opnames.h
+++ b/opnames.h
@@ -423,10 +423,13 @@ typedef enum opcode {
 	OP_ISWEAK	 = 406,
 	OP_WEAKEN	 = 407,
 	OP_UNWEAKEN	 = 408,
+	OP_BLESSED	 = 409,
+	OP_REFADDR	 = 410,
+	OP_REFTYPE	 = 411,
 	OP_max		
 } opcode;
 
-#define MAXO 409
+#define MAXO 412
 #define OP_FREED MAXO
 
 /* the OP_IS_* macros are optimized to a simple range check because
diff --git a/pp.c b/pp.c
index 202cac6c1c..79b73e45a1 100644
--- a/pp.c
+++ b/pp.c
@@ -7253,6 +7253,60 @@ PP(pp_unweaken)
     RETURN;
 }
 
+PP(pp_blessed)
+{
+    dSP;
+    dTARGET;
+    SV *arg = POPs;
+    SV *rv;
+
+    SvGETMAGIC(arg);
+
+    if(SvROK(arg) && SvOBJECT((rv = SvRV(arg)))) {
+        sv_ref(TARG, rv, TRUE);
+        SvSETMAGIC(TARG);
+    }
+    else
+        sv_setsv(TARG, &PL_sv_undef);
+
+    PUSHs(TARG);
+    RETURN;
+}
+
+PP(pp_refaddr)
+{
+    dSP;
+    dTARGET;
+    SV *arg = POPs;
+
+    SvGETMAGIC(arg);
+
+    if(SvROK(arg))
+        sv_setuv_mg(TARG, PTR2UV(SvRV(arg)));
+    else
+        sv_setsv(TARG, &PL_sv_undef);
+
+    PUSHs(TARG);
+    RETURN;
+}
+
+PP(pp_reftype)
+{
+    dSP;
+    dTARGET;
+    SV *arg = POPs;
+
+    SvGETMAGIC(arg);
+
+    if(SvROK(arg))
+        sv_setpv_mg(TARG, sv_reftype(SvRV(arg), FALSE));
+    else
+        sv_setsv(TARG, &PL_sv_undef);
+
+    PUSHs(TARG);
+    RETURN;
+}
+
 /*
  * ex: set ts=8 sts=4 sw=4 et:
  */
diff --git a/pp_proto.h b/pp_proto.h
index ebae2e9cf2..815fedc338 100644
--- a/pp_proto.h
+++ b/pp_proto.h
@@ -32,6 +32,7 @@ PERL_CALLCONV OP *Perl_pp_binmode(pTHX);
 PERL_CALLCONV OP *Perl_pp_bit_and(pTHX);
 PERL_CALLCONV OP *Perl_pp_bit_or(pTHX);
 PERL_CALLCONV OP *Perl_pp_bless(pTHX);
+PERL_CALLCONV OP *Perl_pp_blessed(pTHX);
 PERL_CALLCONV OP *Perl_pp_break(pTHX);
 PERL_CALLCONV OP *Perl_pp_caller(pTHX);
 PERL_CALLCONV OP *Perl_pp_catch(pTHX);
@@ -219,8 +220,10 @@ PERL_CALLCONV OP *Perl_pp_readline(pTHX);
 PERL_CALLCONV OP *Perl_pp_readlink(pTHX);
 PERL_CALLCONV OP *Perl_pp_redo(pTHX);
 PERL_CALLCONV OP *Perl_pp_ref(pTHX);
+PERL_CALLCONV OP *Perl_pp_refaddr(pTHX);
 PERL_CALLCONV OP *Perl_pp_refassign(pTHX);
 PERL_CALLCONV OP *Perl_pp_refgen(pTHX);
+PERL_CALLCONV OP *Perl_pp_reftype(pTHX);
 PERL_CALLCONV OP *Perl_pp_regcomp(pTHX);
 PERL_CALLCONV OP *Perl_pp_regcreset(pTHX);
 PERL_CALLCONV OP *Perl_pp_rename(pTHX);
diff --git a/regen/opcodes b/regen/opcodes
index 523aa32dea..176ca352c4 100644
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -588,3 +588,6 @@ isbool		boolean type test	ck_null		fsT1
 isweak		weakref type test	ck_null		fsT1
 weaken		reference weaken	ck_null		1
 unweaken	reference unweaken	ck_null		1
+blessed		blessed			ck_null		fsT1
+refaddr		refaddr			ck_null		fsT1
+reftype		reftype			ck_null		fsT1
diff --git a/t/perf/opcount.t b/t/perf/opcount.t
index 2be40ee76f..2d3f196174 100644
--- a/t/perf/opcount.t
+++ b/t/perf/opcount.t
@@ -733,4 +733,25 @@ test_opcount(0, "builtin::isweak is replaced with direct opcode",
                     isweak   => 1,
                 });
 
+test_opcount(0, "builtin::blessed is replaced with direct opcode",
+                sub { builtin::blessed([]); },
+                {
+                    entersub => 0,
+                    blessed  => 1,
+                });
+
+test_opcount(0, "builtin::refaddr is replaced with direct opcode",
+                sub { builtin::refaddr([]); },
+                {
+                    entersub => 0,
+                    refaddr  => 1,
+                });
+
+test_opcount(0, "builtin::reftype is replaced with direct opcode",
+                sub { builtin::reftype([]); },
+                {
+                    entersub => 0,
+                    reftype  => 1,
+                });
+
 done_testing();