Как посмотреть конкретный хеш-ключ для изменения его значения?

Question

У меня есть хеш, например $hash->{'foo'}{'bar'},

Я хочу позвонить Carp::cluck в любом месте, где стоимость bar Ключ изменился.

Как это сделать? Есть ли готовый модуль на CPAN, который может сделать этот трюк?

Answer 1

my $hash = { foo => { bar => 1 } };
Internals::SvREADONLY( $hash->{foo}{bar}, 1 );
$hash->{foo}{bar} = 2;

производит

Modification of a read-only value attempted at -e line 4.

Но это фатальная ошибка, и она не содержит трассировки (если не используется Carp::Always).

Я бы порекомендовал добавить набор магии в скаляр.

use Carp            qw( cluck );
use Variable::Magic qw( wizard cast );

my $wizard = wizard(
   set => sub {
      cluck("Warning: Modification of a read-only value attempted");
   },
);

my $hash = { foo => { bar => 1 } };
cast( $hash->{foo}{bar}, $wizard );
$hash->{foo}{bar} = 2;

производит

Warning: Modification of a read-only value attempted at -e line 6.
        main::__ANON__(SCALAR(0x4200c90), undef) called at -e line 12
        eval {...} called at -e line 12

То же самое можно сделать с tie, но это будет дороже. (Связанные переменные построены на magic.)

Answer 2

Tie::Trace почти доставит тебя туда.

use Tie::Trace 'watch';
my $hash = { foo => { bar => "original value" } };
watch $hash->{foo}{bar};
sub f1 { f2() }
sub f2 { f3() }
sub f3 { $hash->{foo}{bar} = "new value" }
f1();

Выход:

'new value' at watch.pl line 6

Вы можете заставить вывод производить полную трассировку стека, импортируя Carp::Always или мартышкой исправляя Tie::Trace::_carpit функция или с $SIG{__WARN__} как обработчик

$SIG{__WARN__} = sub {
    if (caller(0) eq 'Tie::Trace') {
        # warning is from Tie::Trace
        Carp::cluck(@_);
    } else {
        CORE::warn(@_);
    }
};
...

Answer 3

Я сделал "простую" функцию для этого, она не работает с хешами, которые содержат массивы:

use v5.28;
use Storable qw(dclone);

my $ori = {
    'hola' => {
        'hola' => 'adios',
        'adios' => 'hola'
    },
    'hey' => 'you'
};
my $copy = dclone($ori);
$ori->{'hola'}{'adios'} = {'good', 'bye', 'hello', 'year'};
compare($ori, $copy, sub { say $_[0]; });

sub compare {
    my $original = shift;
    my $copy = shift;
    my $func = shift;
    for my $el (keys %{$original}) {
        if (ref $original->{$el} eq ref {}) {
                compare($original->{$el}, ref $copy->{$el} 
                        eq ref {} ? $copy->{$el}:{} , $func);
        } else {
            unless ($copy->{$el} eq $original->{$el}) {
                &$func($original->{$el}, {}, $func);
            }
        }
    }
}
~