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

Question

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

我可以想到的一种方法是循环遍历它的类和所有父类，寻找一个名为(""的方法。虽然这听起来有点恶心，但当你考虑到失误时，情况会变得复杂起来。(所谓回退，我的意思是一个类可能不会重载+运算符，但如果它重载了对数字的转换，Perl就可以回退到使用它来实现加法。(

Answer 1

有一个宏可以检查类(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, 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]";
}