Пользовательские сохраняемые крючки для клонирования легкого объекта, ссылающегося на тяжелый объект

Question

Скажем, у меня есть крошечный объект, имеющий ссылку на огромный объект:

package Tiny;

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

Я хотел бы создать пару STORABLE_freeze / STORABLE_thaw, которая позволит мне (рекурсивно) клонировать $tiny, но сохранить / сохранить ссылку на $large как есть, без клонирования $ large.

Я попытался временно удалить $self->{large} (см. Ниже) и поместить его в хеш с ключом Scalar::Util::refaddr и слабой ссылкой на $large, сериализовать оставшуюся часть $self, а затем поставить (слабый) ) немедленно ссылаются как на исходный объект, так и на клонированный в STORABLE_thaw, но это беспорядок, и при каждом клоне слабое значение ref удаляется, когда выходит из области видимости, но Клавиша остается в хэше навсегда утечка памяти, и мне нужен глобальный хэш члена класса (%largeWeakRefs) для хранения временной ссылки $large. Имеет запах.

Как это возможно сделать чище?

Вот мое решение, использующее хеш для временного хранения большого реф:

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

(Да, я знаю, мой пример касается только клонирования, а не прямой заморозки и оттаивания)

Answer 1

Вы можете добавить количество ссылок.

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 и 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, чтобы избежать потенциальной утечки памяти.

---

Чтобы избежать возможной утечки памяти, никогда не сохраняйте "large" в объекте.

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(@_);
   }
}

Не проверено.

Нет утечек памяти, если процесс клонирования завершается.