diff options
-rw-r--r-- | builtin.c | 15 | ||||
-rw-r--r-- | ext/Opcode/Opcode.pm | 1 | ||||
-rw-r--r-- | lib/B/Deparse.pm | 3 | ||||
-rw-r--r-- | lib/B/Deparse.t | 3 | ||||
-rw-r--r-- | lib/B/Op_private.pm | 7 | ||||
-rw-r--r-- | lib/builtin.pm | 24 | ||||
-rw-r--r-- | lib/builtin.t | 20 | ||||
-rw-r--r-- | opcode.h | 23 | ||||
-rw-r--r-- | opnames.h | 5 | ||||
-rw-r--r-- | pp.c | 54 | ||||
-rw-r--r-- | pp_proto.h | 3 | ||||
-rw-r--r-- | regen/opcodes | 3 | ||||
-rw-r--r-- | t/perf/opcount.t | 21 |
13 files changed, 177 insertions, 5 deletions
@@ -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 @@ -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), }; @@ -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 @@ -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(); |