Perl 自定义可存储挂钩，用于克隆引用重型对象的轻型对象

假设我有一个小对象，它引用了一个大对象：

package Tiny;

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

我想创建一个

STORABLE\u freeze

/

STORABLE\u thaw

对，它允许我（递归地）克隆

$tiny

，但保持对

$large

的引用不变，而不克隆$large

我尝试临时删除

$self->{large}

（见下文），并使用

标量：：Util：：refaddr

键和对

$large

的弱引用将其放入哈希中，序列化

$self

的其余部分，然后放入（弱）立即引用回原始对象和

STORABLE_-saw

中的克隆对象，但这是一个混乱，在每个克隆上，弱ref值在超出范围时被删除，但密钥仍保留在哈希中，永久泄漏内存，我需要一个全局类成员哈希（

%largeWeakRefs

）保存临时

$large

引用。他有气味

如何以更干净的方式做到这一点

下面是我的解决方案，它使用散列临时保存大的ref：

package Tiny;

use Scalar::Util qw(refaddr weaken);

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

# Ugly temporary storage to hold $large refs from _freeze to _thaw...
my %largeWeakRefs;
sub STORABLE_freeze {
    my ( $self, $cloning ) = @_;
    my $large = delete local $self->{large};
    my $refaddr = refaddr $large;
    $largeWeakRefs{$refaddr} = $large;
    weaken $largeWeakRefs{$refaddr};
    my %restOfSelf = %$self;
    $self->{large} = $large;
    return $refaddr, \%restOfSelf;
}

sub STORABLE_thaw {
    my ($self, $cloning, $refaddr, $restOfSelf) = @_;
    %$self = %$restOfSelf;
    $self->{large} = $largeWeakRefs{$refaddr};
    return $self;
}

---

（是的，我知道，我的示例只处理克隆，而不是直接冻结和解冻）

您可以添加引用计数

my %larges;

sub STORABLE_freeze {
   my ( $self, $cloning ) = @_;
   if ($cloning) {
      my $large_key = pack('j', refaddr(self->{large})); 
      $larges{$large_key} //= [ $self->{large}, 0 ];
      ++$larges{$large_key}[1];
      return ( $large_key, $self->{tiny} );
   } else {
      return ( "", $self->{tiny}, $self->{large} );
   }
}

sub STORABLE_thaw {
   my ( $self, $cloning, $serialized ) = splice(@_, 0, 3);
   if ($cloning) {
      my $large_key = $serialized;
      $self->{ tiny  } = shift;
      $self->{ large } = $larges{$large_key}[0];
      --$larges{$large_key}[1]
         or delete($larges{$large_key});
   } else {
      $self->{ tiny  } = shift;
      $self->{ large } = shift;
   }
}

未经测试

如果克隆过程终止，您将出现内存泄漏

---

或者，您可以通过以下方式避免对外部资源的需求：

use Inline C => <<'__EOS__';

   IV get_numeric_ref(SV *sv) {
      SvGETMAGIC(sv);
      if (!SvROK(sv))
         croak("Argument not a reference");

      sv = MUTABLE_SV(SvRV(sv));
      SvREFCNT_inc(sv);
      return PTR2IV(sv);   /* Despite its name, can be used to convert pointer to IV */
   }

   SV* get_perl_ref_from_numeric_ref(IV iv) {
      SV* sv = PTR2IV(iv);
      return newRV_noinc(sv);
   }

__EOS__

sub STORABLE_freeze {
   my ( $self, $cloning ) = @_;
   if ($cloning) {
      return ( pack('j', get_numeric_ref($self->{large})), $self->{tiny} );
   } else {
      return ( "", $self->{tiny}, $self->{large} );
   }
}

sub STORABLE_thaw {
   my ( $self, $cloning, $serialized ) = splice(@_, 0, 3);
   if ($cloning) {
      $self->{ tiny  } = shift;
      $self->{ large } = get_perl_ref_from_numeric_ref(unpack('j', $serialized));
   } else {
      $self->{ tiny  } = shift;
      $self->{ large } = shift;
   }
}

如果克隆过程终止，您将出现内存泄漏。我认为在克隆过程中，依靠“大”不去任何地方是安全的，因此您可以删除

SvREFCNT_inc

并将

newRV_noinc

更改为

newRV

，以避免潜在的内存泄漏

---

为避免可能的内存泄漏，切勿在对象中存储“大”

my %larges;

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

sub _init {
   my ($self, $tiny, $large) = @_;
   $self->{ tiny } = $tiny;

   {
      my $large_key = pack('j', refaddr($self));
      $self->{ large_key } = $large_key;
      $larges{ $large_key } = $large;
   }

   return $self;
}

sub DESTROY {
   my ($self) = @_;
   if (defined( my $large_key = $self->{ large_key } )) {
      delete( $larges{ $large_key } );
   }
}

sub STORABLE_freeze {
   my ( $self, $cloning ) = @_;
   if ($cloning) {
      return ( $self->{large_key}, $self->{tiny} );
   } else {
      return ( "", $self->{tiny}, $larges{ $self->{large_key} } );
   }
}

sub STORABLE_thaw {
   my ( $self, $cloning, $serialized ) = splice(@_, 0, 3);
   if ($cloning) {
      my ($tiny) = @_;
      my $large_key = $serialized;
      $self->_init($tiny, $larges{ $large_key });
   } else {
      $self->_init(@_);
   }
}

未经测试

---

如果克隆过程结束，则不会发生内存泄漏。

谢谢，我添加了引用计数。好主意！

my %larges;

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

sub _init {
   my ($self, $tiny, $large) = @_;
   $self->{ tiny } = $tiny;

   {
      my $large_key = pack('j', refaddr($self));
      $self->{ large_key } = $large_key;
      $larges{ $large_key } = $large;
   }

   return $self;
}

sub DESTROY {
   my ($self) = @_;
   if (defined( my $large_key = $self->{ large_key } )) {
      delete( $larges{ $large_key } );
   }
}

sub STORABLE_freeze {
   my ( $self, $cloning ) = @_;
   if ($cloning) {
      return ( $self->{large_key}, $self->{tiny} );
   } else {
      return ( "", $self->{tiny}, $larges{ $self->{large_key} } );
   }
}

sub STORABLE_thaw {
   my ( $self, $cloning, $serialized ) = splice(@_, 0, 3);
   if ($cloning) {
      my ($tiny) = @_;
      my $large_key = $serialized;
      $self->_init($tiny, $larges{ $large_key });
   } else {
      $self->_init(@_);
   }
}