Perl - 子例程“Hash::Merge::merge”的深度递归

下列的this问题，我在那里使用了答案（也发布在这里），现在我失败了。 我知道失败可能来自于“return bless $self->merge($left, $right), $class_left;”，但我不明白可能是什么问题。

My code:

#!usr/bin/perl
use strict;
use warnings;
use Hash::Merge;
use Data::Dumper;
$Data::Dumper::Sortkeys = 1;
use Data::Structure::Util qw(unbless);


my $hash1 = bless( {
    'Instance' => {
        'pipe_2' => {
            'LineNumber' => bless( do{\(my $o = '200773952')}, 'Veri::ColLineFile' )
        }
    },
}, 'IB' );

my $hash2 = bless( {
    'Instance' => {
        'pipe_2' => {
            'LineNumber' => bless( do{\(my $o = '200773952')}, 'Veri::ColLineFile' )
        }
    },
}, 'IB' );

my $merger = Hash::Merge->new('LEFT_PRECEDENT');
my $behavior = $merger->get_behavior_spec($merger->get_behavior);
my $old_behavior_scalar_scalar = $behavior->{SCALAR}{SCALAR};
$behavior->{SCALAR}{SCALAR} = sub {
    my $self  = &Hash::Merge::_get_obj;
    my ($left, $right) = @_;
    my ($class_left, $class_right) = (ref $left, ref $right);
    print("left = $left, class_left = $class_left right = $right, class_right = $class_right \n");  # I ADDED THIS LINE FOR DEBUGGING
    if ($class_left && $class_left eq $class_right) {
        unbless $left;
        unbless $right;
        return bless $self->merge($left, $right), $class_left;
    } else {
        # Regular scalars, use old behavior
        return $old_behavior_scalar_scalar->($left, $right);
    }
};
my $hash3 = $merger->merge($hash2, $hash1);

print Dumper($hash3);

Output:

Deep recursion on subroutine "Hash::Merge::merge" at ../rrr line 40.
Deep recursion on anonymous subroutine at ...../freeware/cpan/5.18.4/1/el-7-x86_64/lib/perl5/Hash/Merge.pm line 227.

添加调试行后：

left = SCALAR(0x2db6d70), class_left = SCALAR right = SCALAR(0x2db6d88), class_right = SCALAR
left = SCALAR(0x2db7268), class_left = SCALAR right = SCALAR(0x2db7280), class_right = SCALAR
left = SCALAR(0x2db7760), class_left = SCALAR right = SCALAR(0x2db7778), class_right = SCALAR
left = SCALAR(0x2db9e40), class_left = SCALAR right = SCALAR(0x2db9e58), class_right = SCALAR
left = SCALAR(0x2dba338), class_left = SCALAR right = SCALAR(0x2dba350), class_right = SCALAR
left = SCALAR(0x2dba830), class_left = SCALAR right = SCALAR(0x2dba848), class_right = SCALAR
left = SCALAR(0x2dbad28), class_left = SCALAR right = SCALAR(0x2dbad40), class_right = SCALAR
.... #endless lines

*** 编辑后：***

这个案例（神秘地）确实有效。

my $hash1 = bless( {
    'Instance' => {
        'pipe_2' => {
            'veri_id' => [
                bless( do{\(my $o = '201142064')}, 'Verific::VeriIdDef' )
            ]
        }
    },
}, 'IB' );

my $hash2 = bless( {
    'Instance' => {
        'pipe_2' => {
            'veri_id' => [
                bless( do{\(my $o = '201142064')}, 'Verific::VeriIdDef' )
            ]
        }
    },
}, 'IB' );

问题是unbless递归地祝福其参数内的所有对象。引用其文档:

请注意，该结构会在受祝福的对象内部查找其他要取消祝福的对象。

在您的示例中，您的 2 个对象受到祝福，并且它们每个都包含一个内部受祝福的对象。做完之后unbless $left，两者的祝福都被移除，并且你永远无法恢复内部的。

要解决这个问题，您可以编写自己的实现unbless如下（为简单起见，假设不必处理 typeglob）：

sub unbless {
    my $r = eval { ${$_[0]} };
    return \$r unless $@;
    $r = eval { [ @{$_[0]} ] };
    return $r unless $@;
    $r = eval { +{ %{$_[0]} } };
    return $r unless $@;
    die "Unable to unbless.";
}

这个函数的想法是，你可以像解引用一个未祝福的引用一样取消引用一个受祝福的引用，然后你可以获取被取消引用的对象的引用，而这不会受到祝福。除此之外，您需要知道引用的基础类型（标量、arrayref、hashref）。功能unbless上面尝试了所有这些eval，并返回有效的那个。

请注意，它不会修改其参数，而是返回一个不被祝福的等价物。这意味着你需要做$left = unbless $left代替unbless $left。另外，不要忘记删除use Data::Structure::Util.

当前代码存在第二个问题：它不处理标量引用，它将永远循环。您可以通过添加针对该情况的简单检查来解决此问题：

$behavior->{SCALAR}{SCALAR} = sub {
    my $self  = &Hash::Merge::_get_obj;
    my ($left, $right) = @_;
    my ($class_left, $class_right) = (ref $left, ref $right);
    print("left = $left, class_left = $class_left right = $right, class_right = $class_right \n");  # I ADDED THIS LINE FOR DEBUGGING
    if ($class_left && $class_left eq $class_right) {
        if ($class_left eq 'SCALAR') {
            return \($self->merge($$left, $$right));
        } else {
            $left = unbless($left);
            $right = unbless($right);
            return bless $self->merge($left, $right), $class_left;
        }
    } else {
        # Regular scalars, use old behavior
        return $old_behavior_scalar_scalar->($left, $right);
    }
};