Perl：如何深度复制受祝福的对象？

Question

我正在寻找一个受祝福对象的深层（此时，浅层可能就足够了）副本。

Foo 类

package Foo;
our $FOO = new Foo;       # initial run

sub new {
   my $class = shift;
   my $self  = {};
   bless $self, $class;
   return $self;
}

主程序

use Foo;
my $copy = $Foo::FOO;     # instead of creating a ref, want to deep copy here
$copy->{bar} = 'bar';

bar 出现在 $Foo::FOO 和 $copy 中。我意识到我可以通过将其设置为$copy = { %{$Foo::FOO} } 来创建该对象的副本，但随后它将不再受到祝福；此外，这仅适用于简单的数据结构（现在不是问题）。是不是只能这样复制，然后祝福（如$copy = bless { %{$Foo::FOO} }, q{Foo};）？

我尽量避免使用 Moose、Clone 或其他非核心模块/包，因此请在回复时记住这一点。更多:)

Answer 1

对不起，我没注意到这句话：

*我试图避免使用 Moose、Clone 或其他非核心模块/包，因此请在回复时记住这一点。加粗使其更加突出:) *

所以这个答案不能被接受！

#!/usr/bin/env perl -w
use strict;
use warnings;
use Storable;
use Data::Dumper;

my $src = {
  foo => 0,
  bar => [0,1]
};

$src -> {baz} = $src;
my $dst = Storable::dclone($src);
print '$src is : '.Dumper($src)."\n";
print '$dst is : '.Dumper($dst)."\n";

Answer 2

@chorba 的回答中的my $copy = bless { %$self }, ref $self; 是不够的。它只会克隆第一层。存储在$self 中的任何引用都不会被克隆。这样做的后果是……

$obj->{ponies} = [qw(Dash Sparkle Jack)];
$clone = $obj->clone;
push @{$clone->{ponies}}, "Pinkie";
print join ", ", @{$obj->{ponies}};  # Dash Sparkle Jack Pinkie

您现在可能没有任何参考资料，但以后可能会有。或者其他人会将一个插入您的对象。或者他们会继承并添加一个。

您可以编写深度克隆例程，但这并不简单。我强烈推荐使用Clone。它没有依赖项，因此您只需将 Clone.pm 复制到您的项目中即可。

另一个替代方案是@Zaid 提到的Storable::dclone，它已经在核心很长时间了。

无论您使用什么，在您的类上提供一个克隆方法都是正确的做法，即使它只是 Clone 或 Storable::dclone 的包装器。这将使您的对象的用户免受您的对象如何被克隆的详细信息。

Answer 3

调用程序没有很好的方法知道“复制一个对象”意味着什么，所以一个对象应该知道如何复制自己。 Perl 的 OO 在这里没有为您提供任何帮助，但常规的做法是这样的：

package Car;

sub clone {
    my ($self) = @_;

    return $self->new(
        ( map { $_ => $self->$_() } qw/make model/ ), # built-in types
        engine => $self->engine->clone(), # copying an object
    );
}

Answer 4

use Storable 'dclone';?

$ corelist Storable

Storable was first released with perl v5.7.3

此外，您还可以摆弄 Storable 挂钩，以更好地控制复制您的对象（不是我已经做到了，但这就是文档所声称的）。

Answer 5

复制应该是 API 的一部分。您模块的用户永远不会知道在创建新对象时需要执行哪些特殊操作（考虑将每个对象注册到包中的 my 哈希中）。

因此，为您的对象提供clone 方法。在里面，你可以使用任何你喜欢的肮脏技巧：

sub clone {
    my $self = shift;
    my $copy = bless { %$self }, ref $self;
    $register{$copy} = localtime; # Or whatever else you need to do with a new object.
    # ...
    return $copy;
}