您如何检查 object 是否使 XS 中的运算符超载？

Question

If my XS function has been passed an SV containing a blessed object, how can I check to see if that object overloads a particular Perl operator? For example, overloading "" .

One way I can think of would be to loop through its class and all parent classes, looking for a method called ("" . That sounds kinda yuck though, and it gets complicated when you consider fallbacks. (By fallbacks, I mean a class might not overload the + operator, but if it overloads conversion to a number, Perl is able to fall back to using that to implement addition.)

Answer 1

There is a macro that checks if there's any overloading for the class ( SvAMAGIC ), but there's no ready-made function to check for specific kinds of overloading. Perl always wants to follow up the check with the actual overloading, so the two are bundled together in Perl_amagic_call in gv.c .

The following checks if an object's class overloads a specific kind of magic:

void has_amagic(SV *sv, IV method) {
   dXSARGS;

   SvGETMAGIC(sv);

   HV *stash;
   MAGIC *mg;
   AMT *amtp;
   CV **cvp;

   if
   (  SvAMAGIC(sv)
   && ( stash = SvSTASH(SvRV(sv)) )
   && Gv_AMG(stash)
   && ( mg = mg_find((const SV*)stash, PERL_MAGIC_overload_table) )
   && AMT_AMAGIC( amtp = (AMT*)mg->mg_ptr )
   && ( cvp = amtp->table )
   && cvp[method]
   ) {
      XSRETURN_YES;
   } else {
      XSRETURN_NO;
   }
}

The problem with this is that it doesn't check for fallbacks. The code that does that is literally thousands of lines long. (That probably includes some code to prepare for doing the fallback.)

---

Full test:

use 5.014;
use warnings;

BEGIN {
   package Foo;

   use overload
      fallback => 1,
      'cmp' => sub { };

   sub new {
      my $class = shift;
      return bless({ @_ }, $class);
   }
}

use Inline C => <<'__EOS__';

void has_amagic(SV *sv, IV method) {
   dXSARGS;

   SvGETMAGIC(sv);

   HV *stash;
   MAGIC *mg;
   AMT *amtp;
   CV **cvp;

   if
   (  SvAMAGIC(sv)
   && ( stash = SvSTASH(SvRV(sv)) )
   && Gv_AMG(stash)
   && ( mg = mg_find((const SV*)stash, PERL_MAGIC_overload_table) )
   && AMT_AMAGIC( amtp = (AMT*)mg->mg_ptr )
   && ( cvp = amtp->table )
   && cvp[method]
   ) {
      XSRETURN_YES;
   } else {
      XSRETURN_NO;
   }
}

__EOS__


my %overloads;
BEGIN {
   # Based on overload.h
   %overloads = (
      AMG_TO_SV      => 0x01,  #  ${}
      AMG_TO_AV      => 0x02,  #  @{}
      AMG_TO_HV      => 0x03,  #  %{}
      AMG_TO_GV      => 0x04,  #  *{}
      AMG_TO_CV      => 0x05,  #  &{}
      AMG_INC        => 0x06,  #  ++
      AMG_DEC        => 0x07,  #  --
      AMG_BOOL       => 0x08,  #  bool
      AMG_NUMER      => 0x09,  #  0+
      AMG_STRING     => 0x0a,  #  ""
      AMG_NOT        => 0x0b,  #  !
      AMG_COPY       => 0x0c,  #  =
      AMG_ABS        => 0x0d,  #  abs
      AMG_NEG        => 0x0e,  #  neg
      AMG_ITER       => 0x0f,  #  <>
      AMG_INT        => 0x10,  #  int
      AMG_LT         => 0x11,  #  <
      AMG_LE         => 0x12,  #  <=
      AMG_GT         => 0x13,  #  >
      AMG_GE         => 0x14,  #  >=
      AMG_EQ         => 0x15,  #  ==
      AMG_NE         => 0x16,  #  !=
      AMG_SLT        => 0x17,  #  lt
      AMG_SLE        => 0x18,  #  le
      AMG_SGT        => 0x19,  #  gt
      AMG_SGE        => 0x1a,  #  ge
      AMG_SEQ        => 0x1b,  #  eq
      AMG_SNE        => 0x1c,  #  ne
      AMG_NOMETHOD   => 0x1d,  #  nomethod
      AMG_ADD        => 0x1e,  #  +
      AMG_ADD_ASS    => 0x1f,  #  +=
      AMG_SUBTR      => 0x20,  #  -
      AMG_SUBTR_ASS  => 0x21,  #  -=
      AMG_MULT       => 0x22,  #  *
      AMG_MULT_ASS   => 0x23,  #  *=
      AMG_DIV        => 0x24,  #  /
      AMG_DIV_ASS    => 0x25,  #  /=
      AMG_MODULO     => 0x26,  #  %
      AMG_MODULO_ASS => 0x27,  #  %=
      AMG_POW        => 0x28,  #  **
      AMG_POW_ASS    => 0x29,  #  **=
      AMG_LSHIFT     => 0x2a,  #  <<
      AMG_LSHIFT_ASS => 0x2b,  #  <<=
      AMG_RSHIFT     => 0x2c,  #  >>
      AMG_RSHIFT_ASS => 0x2d,  #  >>=
      AMG_BAND       => 0x2e,  #  &
      AMG_BAND_ASS   => 0x2f,  #  &=
      AMG_SBAND      => 0x30,  #  &.
      AMG_SBAND_ASS  => 0x31,  #  &.=
      AMG_BOR        => 0x32,  #  |
      AMG_BOR_ASS    => 0x33,  #  |=
      AMG_SBOR       => 0x34,  #  |.
      AMG_SBOR_ASS   => 0x35,  #  |.=
      AMG_BXOR       => 0x36,  #  ^
      AMG_BXOR_ASS   => 0x37,  #  ^=
      AMG_SBXOR      => 0x38,  #  ^.
      AMG_SBXOR_ASS  => 0x39,  #  ^.=
      AMG_NCMP       => 0x3a,  #  <=>
      AMG_SCMP       => 0x3b,  #  cmp
      AMG_COMPL      => 0x3c,  #  ~
      AMG_SCOMPL     => 0x3d,  #  ~.
      AMG_ATAN2      => 0x3e,  #  atan2
      AMG_COS        => 0x3f,  #  cos
      AMG_SIN        => 0x40,  #  sin
      AMG_EXP        => 0x41,  #  exp
      AMG_LOG        => 0x42,  #  log
      AMG_SQRT       => 0x43,  #  sqrt
      AMG_REPEAT     => 0x44,  #  x
      AMG_REPEAT_ASS => 0x45,  #  x=
      AMG_CONCAT     => 0x46,  #  .
      AMG_CONCAT_ASS => 0x47,  #  .=
      AMG_SMART      => 0x48,  #  ~~
      AMG_FTEST      => 0x49,  #  -X
      AMG_REGEXP     => 0x4a,  #  qr
   );
}

use constant \%overloads;

my $o = Foo->new();

my @overloads =
   grep { has_amagic($o, $overloads{$_}) }
      sort { $overloads{$a} <=> $overloads{$b} }
         keys(%overloads);
         
if (@overloads) {
   say join ", ", @overloads;
} else {
   say "[none]";
}