perl - Custom Storable hooks for dclone-ing a light-weight object referencing a heavy-weight object
问题描述
Say I have a tiny object that has a reference to a huge object:
package Tiny;
sub new {
my ($class, $tiny, $large) = @_;
return bless { tiny => $tiny, large => $large };
}
I'd like to create a STORABLE_freeze
/STORABLE_thaw
pair that lets me (recursively) clone $tiny
but maintain/keep the reference to $large
as-is without cloning $large too.
I tried temporarily deleting $self->{large}
(see below), and putting it in a hash with a Scalar::Util::refaddr
key and a weak reference to $large
, serializing the rest of $self
, and then putting the (weak) reference back into both the original object immediately and the cloned one in STORABLE_thaw
, but it is a mess, and on every clone, the weak ref value gets deleted when it goes out of scope, but the key remains in the hash forever leaking memory and I need a global class member hash (%largeWeakRefs
) to hold the temporary $large
reference. Has a smell.
How it that possible to do this in a cleaner way?
Here is my solution using the hash to hold the large ref temporarily:
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;
}
(Yes I know, my example only handles cloning, not straight-up freeze and thaw)
解决方案
您可以添加引用计数。
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;
}
}
没有测试STORABLE_freeze
and STORABLE_thaw
,但使用以下代码测试了 C/XS 代码:
use strict;
use warnings;
use feature qw( say state );
use Cpanel::JSON::XS qw( );
sub _dump {
state $encoder = Cpanel::JSON::XS->new->canonical->allow_nonref;
return $encoder->encode($_[0]);
}
{
my %h = ( a => 4, b => 5 );
say _dump(\%h); # {"a":4,"b":5}
say sprintf "0x%x", \%h; # 0x32cdbf8
say Internals::SvREFCNT(%h); # 1
my $i = get_numeric_ref(\%h);
say sprintf "0x%x", $i; # 0x32cdbf8
say Internals::SvREFCNT(%h); # 2
my $ref = get_perl_ref_from_numeric_ref($i);
say sprintf "0x%x", $ref; # 0x32cdbf8
say Internals::SvREFCNT(%h); # 2
say _dump($ref); # {"a":4,"b":5}
}
如果克隆过程终止,您将遇到内存泄漏。我想在克隆过程中依靠“大”不去任何地方是安全的,因此您可以删除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(@_);
}
}
未经测试。
如果克隆过程终止,则不会发生内存泄漏。
推荐阅读
- c# - 异步删除显示数据的问题
- .net-core - EF Core 引用同一张表,单个集合
- reactjs - 在无状态组件中获取 ref
- javascript - 与 ng-options 中的硬编码 json 相比,解析我的动态 json 时出错
- google-cloud-platform - 如何在没有 ?authuser=1 的情况下获得经过身份验证的 GCS URL
- swift - 运行应用程序时,表格视图单元上未显示 Swift 按钮
- amazon-web-services - AWS Classic Load Balancer 随机不接收请求
- python - 用于单词计数、平均单词长度、单词频率和以字母开头的单词频率的 Python 程序
- android - (Mockito + Kotlin) Android 测试中的 eq() 和 any() 返回 null
- mysql - 只有当另一列正常时,sql才想计算一列