您如何检查对象是否重载了 XS 中的运算符？

Question

如果向我的 XS 函数传递了一个包含祝福对象的 SV，我如何检查该对象是否重载了特定的 Perl 运算符？例如，重载 "".

我能想到的一种方法是遍历它的 class 和所有父 classes，寻找一个名为 ("" 的方法。这听起来有点恶心，而且当你考虑回退时它会变得复杂。（通过后备，我的意思是 class 可能不会重载 + 运算符，但如果它重载转换为数字，Perl 能够回退到使用它来实现加法。）

Answer 1

有一个宏可以检查 class (SvAMAGIC) 是否有任何重载，但是没有 ready-made 函数来检查特定类型的重载。 Perl 总是想用实际的重载跟进检查，所以在 gv.c.

中将两者捆绑在一起 Perl_amagic_call

以下检查对象的 class 是否超载了特定类型的魔法：

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;
   }
}

问题是它不检查回退。执行此操作的代码实际上有数千行。（这可能包括一些代码来准备回退。）

完整测试：

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]";
}

您如何检查对象是否重载了 XS 中的运算符？

How do you check to see if an object overloads an operator in XS?

perl

operator-overloading

xs