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

问题描述

如果我的XS函数已经传递了包含受祝福对象的SV，如何检查该对象是否使特定的Perl运算符过载？例如，""超载。

我能想到的一种方法是遍历其类和所有父类，寻找一种名为(""的方法。但是，这听起来有点不对劲，当您考虑后备时，情况会变得复杂。 （通过回退，我的意思是一个类可能不会重载+运算符，但是如果它重载了转换为数字的操作，Perl可以回退到使用它来实现加法。）

解决方法

有一个宏可以检查类（SvAMAGIC）是否有任何重载，但是没有现成的函数来检查特定类型的重载。 Perl始终希望对检查进行实际的重载，因此将两者捆绑在Perl_amagic_call中的gv.c中。

以下内容检查对象的类是否重载特定类型的魔术：

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